theory ETCS_Quantifier
  imports ETCS_Pred ETCS_Func
begin

definition FORALL :: "cset \<Rightarrow> cfunc" where
  "FORALL X = (THE \<chi>. is_pullback one one (\<Omega>\<^bsup>X\<^esup>) \<Omega> (\<beta>\<^bsub>one\<^esub>) \<t> ((\<t> \<circ>\<^sub>c \<beta>\<^bsub>X \<times>\<^sub>c one\<^esub>)\<^sup>\<sharp>) \<chi>)"

lemma FORALL_is_pullback:
  "is_pullback one one (\<Omega>\<^bsup>X\<^esup>) \<Omega> (\<beta>\<^bsub>one\<^esub>) \<t> ((\<t> \<circ>\<^sub>c \<beta>\<^bsub>X \<times>\<^sub>c one\<^esub>)\<^sup>\<sharp>) (FORALL X)"
  unfolding FORALL_def
  using characteristic_function_exists element_monomorphism
  by (typecheck_cfuncs, rule_tac the1I2, auto)

lemma FORALL_type[type_rule]:
  "FORALL X : \<Omega>\<^bsup>X\<^esup> \<rightarrow> \<Omega>"
  using FORALL_is_pullback unfolding is_pullback_def square_commutes_def by auto

lemma all_true_implies_FORALL_true:
  assumes p_type: "p : X \<rightarrow> \<Omega>" and all_p_true: "\<And> x. x \<in>\<^sub>c X \<Longrightarrow> p \<circ>\<^sub>c x = \<t>"
  shows "FORALL X \<circ>\<^sub>c (p \<circ>\<^sub>c left_cart_proj X one)\<^sup>\<sharp> = \<t>"
proof -
  have "p \<circ>\<^sub>c left_cart_proj X one = \<t> \<circ>\<^sub>c \<beta>\<^bsub>X \<times>\<^sub>c one\<^esub>"
  proof (rule one_separator[where X="X \<times>\<^sub>c one", where Y="\<Omega>"])
    show "p \<circ>\<^sub>c left_cart_proj X one : X \<times>\<^sub>c one \<rightarrow> \<Omega>"
      using p_type by typecheck_cfuncs
    show "\<t> \<circ>\<^sub>c \<beta>\<^bsub>X \<times>\<^sub>c one\<^esub> : X \<times>\<^sub>c one \<rightarrow> \<Omega>"
      by typecheck_cfuncs
  next
    fix x
    assume x_type: "x \<in>\<^sub>c X \<times>\<^sub>c one"

    have "(p \<circ>\<^sub>c left_cart_proj X one) \<circ>\<^sub>c x = p \<circ>\<^sub>c (left_cart_proj X one \<circ>\<^sub>c x)"
      using x_type p_type comp_associative2 by (typecheck_cfuncs, auto)
    also have "... = \<t>"
      using x_type all_p_true by (typecheck_cfuncs, auto)
    also have "... = \<t> \<circ>\<^sub>c \<beta>\<^bsub>X \<times>\<^sub>c one\<^esub> \<circ>\<^sub>c x "
      using x_type by (typecheck_cfuncs, metis id_right_unit2 id_type one_unique_element)
    also have "... = (\<t> \<circ>\<^sub>c \<beta>\<^bsub>X \<times>\<^sub>c one\<^esub>) \<circ>\<^sub>c x"
      using x_type comp_associative2 by (typecheck_cfuncs, auto)

    then show "(p \<circ>\<^sub>c left_cart_proj X one) \<circ>\<^sub>c x = (\<t> \<circ>\<^sub>c \<beta>\<^bsub>X \<times>\<^sub>c one\<^esub>) \<circ>\<^sub>c x"
      using calculation by auto
  qed
  then have "(p \<circ>\<^sub>c left_cart_proj X one)\<^sup>\<sharp> = (\<t> \<circ>\<^sub>c \<beta>\<^bsub>X \<times>\<^sub>c one\<^esub>)\<^sup>\<sharp>"
    by simp
  then have "FORALL X \<circ>\<^sub>c (p \<circ>\<^sub>c left_cart_proj X one)\<^sup>\<sharp> = \<t> \<circ>\<^sub>c \<beta>\<^bsub>one\<^esub>"
    using FORALL_is_pullback unfolding is_pullback_def square_commutes_def by auto
  then show "FORALL X \<circ>\<^sub>c (p \<circ>\<^sub>c left_cart_proj X one)\<^sup>\<sharp> = \<t>"
    using NOT_false_is_true NOT_is_pullback is_pullback_def square_commutes_def by auto
qed

lemma all_true_implies_FORALL_true2:
  assumes p_type[type_rule]: "p : X \<times>\<^sub>c Y \<rightarrow> \<Omega>" and all_p_true: "\<And> xy. xy \<in>\<^sub>c X \<times>\<^sub>c Y \<Longrightarrow> p \<circ>\<^sub>c xy = \<t>"
  shows "FORALL X \<circ>\<^sub>c p\<^sup>\<sharp> = \<t> \<circ>\<^sub>c \<beta>\<^bsub>Y\<^esub>"
proof -
  have "p = \<t> \<circ>\<^sub>c \<beta>\<^bsub>X \<times>\<^sub>c Y\<^esub>"
  proof (rule one_separator[where X="X \<times>\<^sub>c Y", where Y=\<Omega>])
    show "p : X \<times>\<^sub>c Y \<rightarrow> \<Omega>"
      by typecheck_cfuncs
    show "\<t> \<circ>\<^sub>c \<beta>\<^bsub>X \<times>\<^sub>c Y\<^esub> : X \<times>\<^sub>c Y \<rightarrow> \<Omega>"
      by typecheck_cfuncs
  next
    fix xy
    assume xy_type[type_rule]: "xy \<in>\<^sub>c X \<times>\<^sub>c Y"
    then have "p \<circ>\<^sub>c xy = \<t>"
      using all_p_true by blast
    then have "p \<circ>\<^sub>c xy = \<t> \<circ>\<^sub>c (\<beta>\<^bsub>X \<times>\<^sub>c Y\<^esub> \<circ>\<^sub>c xy)"
      by (typecheck_cfuncs, metis id_right_unit2 id_type one_unique_element)
    then show "p \<circ>\<^sub>c xy = (\<t> \<circ>\<^sub>c \<beta>\<^bsub>X \<times>\<^sub>c Y\<^esub>) \<circ>\<^sub>c xy"
      by (typecheck_cfuncs, smt comp_associative2)
  qed
  then have "p\<^sup>\<sharp> = (\<t> \<circ>\<^sub>c \<beta>\<^bsub>X \<times>\<^sub>c Y\<^esub>)\<^sup>\<sharp>"
    by blast
  then have "p\<^sup>\<sharp> = (\<t> \<circ>\<^sub>c \<beta>\<^bsub>X \<times>\<^sub>c one\<^esub> \<circ>\<^sub>c (id X \<times>\<^sub>f \<beta>\<^bsub>Y\<^esub>))\<^sup>\<sharp>"
    by (typecheck_cfuncs, metis terminal_func_unique)
  then have "p\<^sup>\<sharp> = ((\<t> \<circ>\<^sub>c \<beta>\<^bsub>X \<times>\<^sub>c one\<^esub>) \<circ>\<^sub>c (id X \<times>\<^sub>f \<beta>\<^bsub>Y\<^esub>))\<^sup>\<sharp>"
    by (typecheck_cfuncs, smt comp_associative2)
  then have "p\<^sup>\<sharp> = (\<t> \<circ>\<^sub>c \<beta>\<^bsub>X \<times>\<^sub>c one\<^esub>)\<^sup>\<sharp> \<circ>\<^sub>c \<beta>\<^bsub>Y\<^esub>"
    by (typecheck_cfuncs, simp add: sharp_comp)
  then have "FORALL X \<circ>\<^sub>c p\<^sup>\<sharp> = (FORALL X \<circ>\<^sub>c (\<t> \<circ>\<^sub>c \<beta>\<^bsub>X \<times>\<^sub>c one\<^esub>)\<^sup>\<sharp>) \<circ>\<^sub>c \<beta>\<^bsub>Y\<^esub>"
    by (typecheck_cfuncs, smt comp_associative2)
  then have "FORALL X \<circ>\<^sub>c p\<^sup>\<sharp> = (\<t> \<circ>\<^sub>c \<beta>\<^bsub>one\<^esub>) \<circ>\<^sub>c \<beta>\<^bsub>Y\<^esub>"
    using FORALL_is_pullback unfolding is_pullback_def square_commutes_def by auto
  then show "FORALL X \<circ>\<^sub>c p\<^sup>\<sharp> = \<t> \<circ>\<^sub>c \<beta>\<^bsub>Y\<^esub>"
    by (metis id_right_unit2 id_type terminal_func_unique true_func_type)
qed

lemma FORALL_true_implies_all_true:
  assumes p_type: "p : X \<rightarrow> \<Omega>" and FORALL_p_true: "FORALL X \<circ>\<^sub>c (p \<circ>\<^sub>c left_cart_proj X one)\<^sup>\<sharp> = \<t>"
  shows "\<And> x. x \<in>\<^sub>c X \<Longrightarrow> p \<circ>\<^sub>c x = \<t>"
proof (rule ccontr)
  fix x
  assume x_type: "x \<in>\<^sub>c X"

  assume "p \<circ>\<^sub>c x \<noteq> \<t>"
  then have "p \<circ>\<^sub>c x = \<f>"
    using comp_type p_type true_false_only_truth_values x_type by blast
  then have "p \<circ>\<^sub>c left_cart_proj X one \<circ>\<^sub>c \<langle>x, id one\<rangle> = \<f>"
    using id_type left_cart_proj_cfunc_prod x_type by auto
  then have p_left_proj_false: "p \<circ>\<^sub>c left_cart_proj X one \<circ>\<^sub>c \<langle>x, id one\<rangle> = \<f> \<circ>\<^sub>c \<beta>\<^bsub>X \<times>\<^sub>c one\<^esub> \<circ>\<^sub>c \<langle>x, id one\<rangle>"
    using x_type by (typecheck_cfuncs, metis id_right_unit2 one_unique_element)

  have "\<t> \<circ>\<^sub>c id one = FORALL X \<circ>\<^sub>c (p \<circ>\<^sub>c left_cart_proj X one)\<^sup>\<sharp>"
    using FORALL_p_true id_right_unit2 true_func_type by auto
  then obtain j where
      j_type: "j \<in>\<^sub>c one" and
      j_id: "\<beta>\<^bsub>one\<^esub> \<circ>\<^sub>c j = id one" and
      t_j_eq_p_left_proj: "(\<t> \<circ>\<^sub>c \<beta>\<^bsub>X \<times>\<^sub>c one\<^esub>)\<^sup>\<sharp> \<circ>\<^sub>c j = (p \<circ>\<^sub>c left_cart_proj X one)\<^sup>\<sharp>"
    using FORALL_is_pullback p_type unfolding is_pullback_def by (typecheck_cfuncs, blast)
  then have "j = id one"
    using id_type one_unique_element by blast
  then have "(\<t> \<circ>\<^sub>c \<beta>\<^bsub>X \<times>\<^sub>c one\<^esub>)\<^sup>\<sharp> = (p \<circ>\<^sub>c left_cart_proj X one)\<^sup>\<sharp>"
    using id_right_unit2 t_j_eq_p_left_proj p_type by (typecheck_cfuncs, auto)
  then have "\<t> \<circ>\<^sub>c \<beta>\<^bsub>X \<times>\<^sub>c one\<^esub> = p \<circ>\<^sub>c left_cart_proj X one"
    using p_type by (typecheck_cfuncs, metis flat_cancels_sharp)
  then have p_left_proj_true: "\<t> \<circ>\<^sub>c \<beta>\<^bsub>X \<times>\<^sub>c one\<^esub> \<circ>\<^sub>c \<langle>x, id one\<rangle> = p \<circ>\<^sub>c left_cart_proj X one \<circ>\<^sub>c \<langle>x, id one\<rangle>"
    using p_type x_type comp_associative2 by (typecheck_cfuncs, auto)

  have "\<t> \<circ>\<^sub>c \<beta>\<^bsub>X \<times>\<^sub>c one\<^esub> \<circ>\<^sub>c \<langle>x, id one\<rangle> = \<f> \<circ>\<^sub>c \<beta>\<^bsub>X \<times>\<^sub>c one\<^esub> \<circ>\<^sub>c \<langle>x, id one\<rangle>"
    using p_left_proj_false p_left_proj_true by auto
  then have "\<t> \<circ>\<^sub>c id one = \<f> \<circ>\<^sub>c id one"
    by (metis id_type right_cart_proj_cfunc_prod right_cart_proj_type terminal_func_unique x_type)
  then have "\<t> = \<f>"
    using true_func_type false_func_type id_right_unit2 by auto
  then show False
    using true_false_distinct by auto
qed

lemma FORALL_true_implies_all_true2:
  assumes p_type[type_rule]: "p : X \<times>\<^sub>c Y \<rightarrow> \<Omega>" and FORALL_p_true: "FORALL X \<circ>\<^sub>c p\<^sup>\<sharp> = \<t> \<circ>\<^sub>c \<beta>\<^bsub>Y\<^esub>"
  shows "\<And> x y. x \<in>\<^sub>c X \<Longrightarrow> y \<in>\<^sub>c Y \<Longrightarrow> p \<circ>\<^sub>c \<langle>x, y\<rangle> = \<t>"
proof -
  have "p\<^sup>\<sharp> = (\<t> \<circ>\<^sub>c \<beta>\<^bsub>X \<times>\<^sub>c one\<^esub>)\<^sup>\<sharp> \<circ>\<^sub>c \<beta>\<^bsub>Y\<^esub>"
    using FORALL_is_pullback FORALL_p_true unfolding is_pullback_def
    by (typecheck_cfuncs, metis terminal_func_unique)
  then have "p\<^sup>\<sharp> = ((\<t> \<circ>\<^sub>c \<beta>\<^bsub>X \<times>\<^sub>c one\<^esub>) \<circ>\<^sub>c (id X \<times>\<^sub>f \<beta>\<^bsub>Y\<^esub>))\<^sup>\<sharp>"
    by (typecheck_cfuncs, simp add: sharp_comp)
  then have "p\<^sup>\<sharp> = (\<t> \<circ>\<^sub>c \<beta>\<^bsub>X \<times>\<^sub>c Y\<^esub>)\<^sup>\<sharp>"
    by (typecheck_cfuncs_prems, smt (z3) comp_associative2 terminal_func_comp)
  then have "p = \<t> \<circ>\<^sub>c \<beta>\<^bsub>X \<times>\<^sub>c Y\<^esub>"
    by (typecheck_cfuncs, metis flat_cancels_sharp)
  then have "\<And> x y. x \<in>\<^sub>c X \<Longrightarrow> y \<in>\<^sub>c Y \<Longrightarrow> p \<circ>\<^sub>c \<langle>x, y\<rangle> = (\<t> \<circ>\<^sub>c \<beta>\<^bsub>X \<times>\<^sub>c Y\<^esub>) \<circ>\<^sub>c \<langle>x, y\<rangle>"
    by auto
  then show "\<And> x y. x \<in>\<^sub>c X \<Longrightarrow> y \<in>\<^sub>c Y \<Longrightarrow> p \<circ>\<^sub>c \<langle>x, y\<rangle> = \<t>"
  proof -
    fix x y
    assume xy_types[type_rule]: "x \<in>\<^sub>c X" "y \<in>\<^sub>c Y"
    assume "\<And>x y. x \<in>\<^sub>c X \<Longrightarrow> y \<in>\<^sub>c Y \<Longrightarrow> p \<circ>\<^sub>c \<langle>x,y\<rangle> = (\<t> \<circ>\<^sub>c \<beta>\<^bsub>X \<times>\<^sub>c Y\<^esub>) \<circ>\<^sub>c \<langle>x,y\<rangle>"
    then have "p \<circ>\<^sub>c \<langle>x,y\<rangle> = (\<t> \<circ>\<^sub>c \<beta>\<^bsub>X \<times>\<^sub>c Y\<^esub>) \<circ>\<^sub>c \<langle>x,y\<rangle>"
      using xy_types by auto
    then have "p \<circ>\<^sub>c \<langle>x,y\<rangle> = \<t> \<circ>\<^sub>c (\<beta>\<^bsub>X \<times>\<^sub>c Y\<^esub> \<circ>\<^sub>c \<langle>x,y\<rangle>)"
      by (typecheck_cfuncs, smt comp_associative2)
    then show "p \<circ>\<^sub>c \<langle>x, y\<rangle> = \<t>"
      by (typecheck_cfuncs_prems, metis id_right_unit2 id_type one_unique_element)
  qed
qed

definition EXISTS :: "cset \<Rightarrow> cfunc" where
  "EXISTS X = NOT \<circ>\<^sub>c FORALL X \<circ>\<^sub>c NOT\<^bsup>X\<^esup>\<^sub>f"

lemma EXISTS_type[type_rule]:
  "EXISTS X : \<Omega>\<^bsup>X\<^esup> \<rightarrow> \<Omega>"
  unfolding EXISTS_def by typecheck_cfuncs

lemma EXISTS_true_implies_exists_true:
  assumes p_type: "p : X \<rightarrow> \<Omega>" and EXISTS_p_true: "EXISTS X \<circ>\<^sub>c (p \<circ>\<^sub>c left_cart_proj X one)\<^sup>\<sharp> = \<t>"
  shows "\<exists> x. x \<in>\<^sub>c X \<and> p \<circ>\<^sub>c x = \<t>"
proof -
  have "NOT \<circ>\<^sub>c FORALL X \<circ>\<^sub>c NOT\<^bsup>X\<^esup>\<^sub>f \<circ>\<^sub>c (p \<circ>\<^sub>c left_cart_proj X one)\<^sup>\<sharp> = \<t>"
    using p_type EXISTS_p_true cfunc_type_def comp_associative comp_type
    unfolding EXISTS_def
    by (typecheck_cfuncs, auto)
  then have "NOT \<circ>\<^sub>c FORALL X \<circ>\<^sub>c (NOT \<circ>\<^sub>c p \<circ>\<^sub>c left_cart_proj X one)\<^sup>\<sharp> = \<t>"
    using p_type transpose_of_comp by (typecheck_cfuncs, auto)
  then have "FORALL X \<circ>\<^sub>c (NOT \<circ>\<^sub>c p \<circ>\<^sub>c left_cart_proj X one)\<^sup>\<sharp> \<noteq> \<t>"
    using NOT_true_is_false true_false_distinct by auto
  then have "FORALL X \<circ>\<^sub>c ((NOT \<circ>\<^sub>c p) \<circ>\<^sub>c left_cart_proj X one)\<^sup>\<sharp> \<noteq> \<t>"
    using p_type comp_associative2 by (typecheck_cfuncs, auto)
  then have "\<not> (\<forall> x. x \<in>\<^sub>c X \<longrightarrow> (NOT \<circ>\<^sub>c p) \<circ>\<^sub>c x = \<t>)"
    using NOT_type all_true_implies_FORALL_true comp_type p_type by blast
  then have "\<not> (\<forall> x. x \<in>\<^sub>c X \<longrightarrow> NOT \<circ>\<^sub>c (p \<circ>\<^sub>c x) = \<t>)"
    using p_type comp_associative2 by (typecheck_cfuncs, auto)
  then have "\<not> (\<forall> x. x \<in>\<^sub>c X \<longrightarrow> p \<circ>\<^sub>c x \<noteq> \<t>)"
    using NOT_false_is_true comp_type p_type true_false_only_truth_values by fastforce
  then show "\<exists>x. x \<in>\<^sub>c X \<and> p \<circ>\<^sub>c x = \<t>"
    by blast
qed

lemma exists_true_implies_EXISTS_true:
  assumes p_type: "p : X \<rightarrow> \<Omega>" and exists_p_true: "\<exists> x. x \<in>\<^sub>c X \<and> p \<circ>\<^sub>c x = \<t>"
  shows  "EXISTS X \<circ>\<^sub>c (p \<circ>\<^sub>c left_cart_proj X one)\<^sup>\<sharp> = \<t>"
proof -
 have "\<not> (\<forall> x. x \<in>\<^sub>c X \<longrightarrow> p \<circ>\<^sub>c x \<noteq> \<t>)"
   using exists_p_true by blast
 then have "\<not> (\<forall> x. x \<in>\<^sub>c X \<longrightarrow> NOT \<circ>\<^sub>c (p \<circ>\<^sub>c x) = \<t>)"
   using NOT_true_is_false true_false_distinct by auto
 then have "\<not> (\<forall> x. x \<in>\<^sub>c X \<longrightarrow> (NOT \<circ>\<^sub>c p) \<circ>\<^sub>c x = \<t>)"
   using p_type by (typecheck_cfuncs, metis NOT_true_is_false cfunc_type_def comp_associative exists_p_true true_false_distinct)
 then have "FORALL X \<circ>\<^sub>c ((NOT \<circ>\<^sub>c p) \<circ>\<^sub>c left_cart_proj X one)\<^sup>\<sharp> \<noteq> \<t>"
   using FORALL_true_implies_all_true NOT_type comp_type p_type by blast
 then have "FORALL X \<circ>\<^sub>c (NOT \<circ>\<^sub>c p \<circ>\<^sub>c left_cart_proj X one)\<^sup>\<sharp> \<noteq> \<t>"
   using NOT_type cfunc_type_def comp_associative left_cart_proj_type p_type by auto
 then have "NOT \<circ>\<^sub>c FORALL X \<circ>\<^sub>c (NOT \<circ>\<^sub>c p \<circ>\<^sub>c left_cart_proj X one)\<^sup>\<sharp> = \<t>"
   using assms NOT_is_false_implies_true true_false_only_truth_values by (typecheck_cfuncs, blast)
 then have "NOT \<circ>\<^sub>c FORALL X \<circ>\<^sub>c NOT\<^bsup>X\<^esup>\<^sub>f \<circ>\<^sub>c (p \<circ>\<^sub>c left_cart_proj X one)\<^sup>\<sharp> = \<t>"
   using assms transpose_of_comp by (typecheck_cfuncs, auto)
 then have "(NOT \<circ>\<^sub>c FORALL X \<circ>\<^sub>c NOT\<^bsup>X\<^esup>\<^sub>f) \<circ>\<^sub>c (p \<circ>\<^sub>c left_cart_proj X one)\<^sup>\<sharp> = \<t>"
    using assms cfunc_type_def comp_associative by (typecheck_cfuncs,auto)
 then show "EXISTS X \<circ>\<^sub>c (p \<circ>\<^sub>c left_cart_proj X one)\<^sup>\<sharp> = \<t>"
  by (simp add: EXISTS_def)
qed

(*
lemma forall_equals:

  assumes p_type[type_rule]: "p : X \<rightarrow> \<Omega>"
  assumes q_type[type_rule]: "q : X \<rightarrow> \<Omega>"
  assumes nonempty: "nonempty(X)"
  assumes equals: "FORALL (X \<^bsub>p\<^esub>\<times>\<^sub>c\<^bsub>q\<^esub> X) \<circ>\<^sub>c ((fibered_product_morphism X p q X) \<circ>\<^sub>c left_cart_proj (X \<^bsub>p\<^esub>\<times>\<^sub>c\<^bsub>q\<^esub> X) one)\<^sup>\<sharp> = \<t>"
  shows "p = q"
proof -
  have "(fibered_product_morphism X p q X) : (X \<^bsub>p\<^esub>\<times>\<^sub>c\<^bsub>q\<^esub> X) \<rightarrow> \<Omega>"
    apply typecheck_cfuncs
    oops
    (*Put the correct type above*)

  have "\<And> x. x \<in>\<^sub>c (X \<^bsub>p\<^esub>\<times>\<^sub>c\<^bsub>q\<^esub> X) \<Longrightarrow> (fibered_product_morphism X p q X)  \<circ>\<^sub>c x = \<t>"
    apply typecheck_cfuncs
(*
lemma forall_equals:
  assumes p_type[type_rule]: "p : X \<rightarrow> \<Omega>"
  assumes q_type[type_rule]: "q : X \<rightarrow> \<Omega>"
  assumes nonempty: "nonempty(X)"
  assumes equals: "FORALL X \<circ>\<^sub>c (p \<circ>\<^sub>c left_cart_proj X one)\<^sup>\<sharp> = FORALL X \<circ>\<^sub>c (q \<circ>\<^sub>c left_cart_proj X one)\<^sup>\<sharp>"
  shows "p = q"
proof(cases "FORALL X \<circ>\<^sub>c (p \<circ>\<^sub>c left_cart_proj X one)\<^sup>\<sharp> = \<t>")
  assume "FORALL X \<circ>\<^sub>c (p \<circ>\<^sub>c left_cart_proj X one)\<^sup>\<sharp> = \<t>"
  show "p = q"
    by (typecheck_cfuncs, metis FORALL_true_implies_all_true \<open>FORALL X \<circ>\<^sub>c (p \<circ>\<^sub>c left_cart_proj X one)\<^sup>\<sharp> = \<t>\<close> equals one_separator)
next
  assume "FORALL X \<circ>\<^sub>c (p \<circ>\<^sub>c left_cart_proj X one)\<^sup>\<sharp> \<noteq> \<t>"
  then have "FORALL X \<circ>\<^sub>c (p \<circ>\<^sub>c left_cart_proj X one)\<^sup>\<sharp> = \<f>"
    using \<open>FORALL X \<circ>\<^sub>c (p \<circ>\<^sub>c left_cart_proj X one)\<^sup>\<sharp> \<noteq> \<t>\<close> true_false_only_truth_values by (typecheck_cfuncs, blast)
  then have "\<And> x. x \<in>\<^sub>c X \<Longrightarrow> p \<circ>\<^sub>c x = \<f> \<Longrightarrow> q \<circ>\<^sub>c x = \<f>"
    apply typecheck_cfuncs

*)

(*
  then have "\<exists> x. x \<in>\<^sub>c X \<and> p \<circ>\<^sub>c x = \<f>"
    apply typecheck_cfuncs
    by (smt (verit, best) \<open>FORALL X \<circ>\<^sub>c (p \<circ>\<^sub>c left_cart_proj X one)\<^sup>\<sharp> = \<f>\<close> all_true_implies_FORALL_true comp_type true_false_distinct true_false_only_truth_values)
*)

*)

end


theory Own
imports ProofRules
begin

context inG begin
definition own :: "gname \<Rightarrow> 'b \<Rightarrow> 'a upred_f" where
  "own \<gamma> x = upred_own (put_cmra \<gamma> x)"

lemma own_ne [upred_ne_rule]: "n_equiv n x y \<Longrightarrow> n_equiv n (own \<gamma> x) (own \<gamma> y)"
  unfolding own_def
  apply (rule upred_own_ne)
  using put_ne by simp

lemma own_valid: "own \<gamma> a \<turnstile> \<V>(a)"
  unfolding own_def
  apply (rule upred_entails_trans[OF upred_own_valid])
  by (auto simp: upred_entails.rep_eq upred_valid.rep_eq put_n_valid)

lemma own_valid': "own \<gamma> a \<turnstile> \<V>(put_cmra \<gamma> a)"
  by (simp add: own_def upred_own_valid)

lemma valid_get: "\<V>(put_cmra \<gamma> a) \<stileturn>\<turnstile> \<V>(a)"
  by (auto simp: upred_valid.rep_eq upred_entail_eq_def upred_entails.rep_eq put_n_valid)

lemma own_op: "own \<gamma> (a\<cdot>b) \<stileturn>\<turnstile> own \<gamma> a \<^emph> own \<gamma> b"
  unfolding own_def put_op
  by (rule upred_own_op)

lemma own_valid2: "own \<gamma> a1 -\<^emph> own \<gamma> a2 -\<^emph> \<V>(a1\<cdot>a2)"
  unfolding own_def
  apply (rule upred_wand_holds2I)
  apply (rule upred_entails_trans[OF upred_wand_holds2E[OF upred_own_valid2]])
  by (auto simp: upred_entails.rep_eq upred_valid.rep_eq put_n_valid put_op[symmetric])

lemma own_alloc: "valid a \<Longrightarrow> \<Rrightarrow>\<^sub>b (own \<gamma> a)"
  sorry (* Axiomatized as proof in Coq is not easily reproducible. *)

lemma own_update: "put_cmra \<gamma> a\<leadsto>{put_cmra \<gamma> b} \<Longrightarrow> own \<gamma> a ==\<^emph> own \<gamma> b"
  unfolding camera_upd_def own_def
  apply (rule upred_wand_holdsI)
  apply transfer'
  apply auto
  by (metis n_incl_refl n_valid_incl_subst)

lemma add_own: "\<lbrakk>valid a; Q\<^emph>(own \<gamma> a)\<turnstile>\<Rrightarrow>\<^sub>bR\<rbrakk> \<Longrightarrow> Q\<turnstile>\<Rrightarrow>\<^sub>bR"
proof -
  assume assms: "valid a" "Q\<^emph>(own \<gamma> a)\<turnstile>\<Rrightarrow>\<^sub>bR"
  from own_alloc[OF this(1)] have "\<Rrightarrow>\<^sub>b own \<gamma> a" .
  from assms(2) have "Q\<^emph>\<Rrightarrow>\<^sub>b own \<gamma> a\<turnstile>\<Rrightarrow>\<^sub>b R"
    by (meson upd_frameR upd_mono upd_idem upred_entails_trans)
  from add_holds[OF \<open>\<Rrightarrow>\<^sub>b own \<gamma> a\<close> this] show ?thesis .
qed

lemma inG_dcamera_val: "dcamera_val (put_cmra \<gamma> a) \<Longrightarrow> dcamera_val a"
  unfolding dcamera_val_def discrete_val_def
  using put_ne
  apply (auto simp: ofe_refl ofe_eq_eq valid_def)
  apply (metis get_put option.inject)
  apply (metis get_put ofe_eq_equiv option.sel)
  using put_n_valid apply blast
  apply (metis get_put option.sel)
  apply (metis get_put ofe_limit option.sel)
  using put_n_valid by blast
end

notation inG.own ("own _ _ _")

context fixes get_cmra :: "gname \<Rightarrow> 'a::ucamera \<Rightarrow> 'b::total_camera option"
  and put_cmra :: "gname \<Rightarrow> 'b \<Rightarrow> 'a"
  assumes inG: "inG get_cmra put_cmra"
begin
lemma own_core_persis: "own put_cmra \<gamma> a \<turnstile> \<box>(own put_cmra \<gamma> (core a))"
  unfolding inG.own_def[OF inG]
  apply (rule upred_entails_trans[OF upred_own_core_persis])
  unfolding core_def
  apply (auto simp: comp_def inG.put_pcore[OF inG])
  using total_pcore
  by (metis option.case_eq_if option.distinct(1) upred_entails_refl)

lemma pcore_id_put: "pcore_id_pred x \<Longrightarrow> pcore_id_pred (put_cmra \<gamma> x)"
  unfolding pcore_id_pred_def inG.put_pcore[OF inG]
  by auto
end
end


(*  Title:      HOL/Isar_Examples/Peirce.thy
    Author:     Makarius
*)

section \<open>Peirce's Law\<close>

theory Peirce
  imports Main
begin

text \<open>
  We consider Peirce's Law: \<open>((A \<longrightarrow> B) \<longrightarrow> A) \<longrightarrow> A\<close>. This is an inherently
  non-intuitionistic statement, so its proof will certainly involve some form
  of classical contradiction.

  The first proof is again a well-balanced combination of plain backward and
  forward reasoning. The actual classical step is where the negated goal may
  be introduced as additional assumption. This eventually leads to a
  contradiction.\<^footnote>\<open>The rule involved there is negation elimination; it holds in
  intuitionistic logic as well.\<close>\<close>

theorem "((A \<longrightarrow> B) \<longrightarrow> A) \<longrightarrow> A"
proof
  assume "(A \<longrightarrow> B) \<longrightarrow> A"
  show A
  proof (rule classical)
    assume "\<not> A"
    have "A \<longrightarrow> B"
    proof
      assume A
      with \<open>\<not> A\<close> show B by contradiction
    qed
    with \<open>(A \<longrightarrow> B) \<longrightarrow> A\<close> show A ..
  qed
qed

text \<open>
  In the subsequent version the reasoning is rearranged by means of ``weak
  assumptions'' (as introduced by \<^theory_text>\<open>presume\<close>). Before assuming the negated
  goal \<open>\<not> A\<close>, its intended consequence \<open>A \<longrightarrow> B\<close> is put into place in order to
  solve the main problem. Nevertheless, we do not get anything for free, but
  have to establish \<open>A \<longrightarrow> B\<close> later on. The overall effect is that of a logical
  \<^emph>\<open>cut\<close>.

  Technically speaking, whenever some goal is solved by \<^theory_text>\<open>show\<close> in the context
  of weak assumptions then the latter give rise to new subgoals, which may be
  established separately. In contrast, strong assumptions (as introduced by
  \<^theory_text>\<open>assume\<close>) are solved immediately.
\<close>

theorem "((A \<longrightarrow> B) \<longrightarrow> A) \<longrightarrow> A"
proof
  assume "(A \<longrightarrow> B) \<longrightarrow> A"
  show A
  proof (rule classical)
    presume "A \<longrightarrow> B"
    with \<open>(A \<longrightarrow> B) \<longrightarrow> A\<close> show A ..
  next
    assume "\<not> A"
    show "A \<longrightarrow> B"
    proof
      assume A
      with \<open>\<not> A\<close> show B by contradiction
    qed
  qed
qed

text \<open>
  Note that the goals stemming from weak assumptions may be even left until
  qed time, where they get eventually solved ``by assumption'' as well. In
  that case there is really no fundamental difference between the two kinds of
  assumptions, apart from the order of reducing the individual parts of the
  proof configuration.

  Nevertheless, the ``strong'' mode of plain assumptions is quite important in
  practice to achieve robustness of proof text interpretation. By forcing both
  the conclusion \<^emph>\<open>and\<close> the assumptions to unify with the pending goal to be
  solved, goal selection becomes quite deterministic. For example,
  decomposition with rules of the ``case-analysis'' type usually gives rise to
  several goals that only differ in there local contexts. With strong
  assumptions these may be still solved in any order in a predictable way,
  while weak ones would quickly lead to great confusion, eventually demanding
  even some backtracking.
\<close>

end


theory Document
  imports Main
begin

section \<open>Some section\<close>

subsection \<open>Some subsection\<close>

subsection \<open>Some subsubsection\<close>

subsubsection \<open>Some subsubsubsection\<close>

paragraph \<open>A paragraph.\<close>

text \<open>Informal bla bla.\<close>

definition "foo = True"  \<comment> \<open>side remark on \<^const>\<open>foo\<close>\<close>

definition "bar = False"  \<comment> \<open>side remark on \<^const>\<open>bar\<close>\<close>

lemma foo unfolding foo_def ..

paragraph \<open>Another paragraph.\<close>

text \<open>See also \<^cite>\<open>\<open>\S3\<close> in "isabelle-system"\<close>.\<close>

section \<open>Formal proof of Cantor's theorem\<close>

text_raw \<open>\isakeeptag{proof}\<close>
text \<open>
  Cantor's Theorem states that there is no surjection from
  a set to its powerset.  The proof works by diagonalization.  E.g.\ see
  \<^item> \<^url>\<open>http://mathworld.wolfram.com/CantorDiagonalMethod.html\<close>
  \<^item> \<^url>\<open>https://en.wikipedia.org/wiki/Cantor%27s%5fdiagonal%5fargument\<close>
\<close>

theorem Cantor: "\<nexists>f :: 'a \<Rightarrow> 'a set. \<forall>A. \<exists>x. A = f x"
proof
  assume "\<exists>f :: 'a \<Rightarrow> 'a set. \<forall>A. \<exists>x. A = f x"
  then obtain f :: "'a \<Rightarrow> 'a set" where *: "\<forall>A. \<exists>x. A = f x" ..
  let ?D = "{x. x \<notin> f x}"
  from * obtain a where "?D = f a" by blast
  moreover have "a \<in> ?D \<longleftrightarrow> a \<notin> f a" by blast
  ultimately show False by blast
qed

subsection \<open>Lorem ipsum dolor\<close>

text \<open>
  Lorem ipsum dolor sit amet, consectetur adipiscing elit. Donec id ipsum
  sapien. Vivamus malesuada enim nibh, a tristique nisi sodales ac. Praesent
  ut sem consectetur, interdum tellus ac, sodales nulla. Quisque vel diam at
  risus tempus tempor eget a tortor. Suspendisse potenti. Nulla erat lacus,
  dignissim sed volutpat nec, feugiat non leo. Nunc blandit et justo sed
  venenatis. Donec scelerisque placerat magna, et congue nulla convallis vel.
  Cras tristique dolor consequat dolor tristique rutrum. Suspendisse ultrices
  sem nibh, et suscipit felis ultricies at. Aliquam venenatis est vel nulla
  efficitur ornare. Lorem ipsum dolor sit amet, consectetur adipiscing elit.
\<close>

end


(* Copyright 2021 (C) Mihails Milehins *)

section\<open>\<open>Rel\<close> as a digraph\<close>
theory CZH_DG_Rel
  imports CZH_DG_Small_DGHM
begin

subsection\<open>Background\<close>

text\<open>
\<open>Rel\<close> is usually defined as a category of sets and binary relations
(e.g., see Chapter I-7 in \<^cite>\<open>"mac_lane_categories_2010"\<close>). However, there
is little that can prevent one from exposing \<open>Rel\<close> as a digraph and
provide additional structure gradually later.
Thus, in this section, \<open>\<alpha>\<close>-\<open>Rel\<close> is defined as a digraph of sets
and binary relations in \<open>V\<^sub>\<alpha>\<close>.
\<close>

named_theorems dg_Rel_shared_cs_simps
named_theorems dg_Rel_shared_cs_intros

named_theorems dg_Rel_cs_simps
named_theorems dg_Rel_cs_intros

subsection\<open>Canonical arrow for \<^typ>\<open>V\<close>\<close>

named_theorems arr_field_simps

definition ArrVal :: V where [arr_field_simps]: "ArrVal = 0"
definition ArrDom :: V where [arr_field_simps]: "ArrDom = 1\<^sub>\<nat>"
definition ArrCod :: V where [arr_field_simps]: "ArrCod = 2\<^sub>\<nat>"

lemma ArrVal_eq_helper:
  assumes "f = g"
  shows "f\<lparr>ArrVal\<rparr>\<lparr>a\<rparr> = g\<lparr>ArrVal\<rparr>\<lparr>a\<rparr>"
  using assms by simp

subsection\<open>Arrow for \<open>Rel\<close>\<close>

subsubsection\<open>Definition and elementary properties\<close>

locale arr_Rel = \<Z> \<alpha> + vfsequence T + ArrVal: vbrelation \<open>T\<lparr>ArrVal\<rparr>\<close> for \<alpha> T +
  assumes arr_Rel_length[dg_Rel_shared_cs_simps, dg_Rel_cs_simps]:
    "vcard T = 3\<^sub>\<nat>"
    and arr_Rel_ArrVal_vdomain: "\<D>\<^sub>\<circ> (T\<lparr>ArrVal\<rparr>) \<subseteq>\<^sub>\<circ> T\<lparr>ArrDom\<rparr>"
    and arr_Rel_ArrVal_vrange: "\<R>\<^sub>\<circ> (T\<lparr>ArrVal\<rparr>) \<subseteq>\<^sub>\<circ> T\<lparr>ArrCod\<rparr>"
    and arr_Rel_ArrDom_in_Vset: "T\<lparr>ArrDom\<rparr> \<in>\<^sub>\<circ> Vset \<alpha>"
    and arr_Rel_ArrCod_in_Vset: "T\<lparr>ArrCod\<rparr> \<in>\<^sub>\<circ> Vset \<alpha>"

lemmas [dg_Rel_shared_cs_simps, dg_Rel_cs_simps] = arr_Rel.arr_Rel_length

text\<open>Components.\<close>

lemma arr_Rel_components[dg_Rel_shared_cs_simps, dg_Rel_cs_simps]:
  shows "[f, A, B]\<^sub>\<circ>\<lparr>ArrVal\<rparr> = f"
    and "[f, A, B]\<^sub>\<circ>\<lparr>ArrDom\<rparr> = A"
    and "[f, A, B]\<^sub>\<circ>\<lparr>ArrCod\<rparr> = B"
  unfolding arr_field_simps by (simp_all add: nat_omega_simps)

text\<open>Rules.\<close>

lemma (in arr_Rel) arr_Rel_axioms'[dg_cs_intros, dg_Rel_cs_intros]:
  assumes "\<alpha>' = \<alpha>"
  shows "arr_Rel \<alpha>' T"
  unfolding assms by (rule arr_Rel_axioms)

mk_ide rf arr_Rel_def[unfolded arr_Rel_axioms_def]
  |intro arr_RelI|
  |dest arr_RelD[dest]|
  |elim arr_RelE[elim!]|

lemma (in \<Z>) arr_Rel_vfsequenceI:
  assumes "vbrelation r"
    and "\<D>\<^sub>\<circ> r \<subseteq>\<^sub>\<circ> a"
    and "\<R>\<^sub>\<circ> r \<subseteq>\<^sub>\<circ> b"
    and "a \<in>\<^sub>\<circ> Vset \<alpha>"
    and "b \<in>\<^sub>\<circ> Vset \<alpha>"
  shows "arr_Rel \<alpha> [r, a, b]\<^sub>\<circ>"
  by (intro arr_RelI)
    (insert assms, auto simp: nat_omega_simps arr_Rel_components)

text\<open>Elementary properties.\<close>

lemma arr_Rel_eqI:
  assumes "arr_Rel \<alpha> S"
    and "arr_Rel \<alpha> T"
    and "S\<lparr>ArrVal\<rparr> = T\<lparr>ArrVal\<rparr>"
    and "S\<lparr>ArrDom\<rparr> = T\<lparr>ArrDom\<rparr>"
    and "S\<lparr>ArrCod\<rparr> = T\<lparr>ArrCod\<rparr>"
  shows "S = T"
proof-
  interpret S: arr_Rel \<alpha> S by (rule assms(1))
  interpret T: arr_Rel \<alpha> T by (rule assms(2))
  show ?thesis
  proof(rule vsv_eqI)
    show "\<D>\<^sub>\<circ> S = \<D>\<^sub>\<circ> T"
      by (simp add: S.vfsequence_vdomain T.vfsequence_vdomain dg_Rel_cs_simps)
    have dom_lhs: "\<D>\<^sub>\<circ> S = 3\<^sub>\<nat>"
      by (simp add: S.vfsequence_vdomain dg_Rel_cs_simps)
    show "a \<in>\<^sub>\<circ> \<D>\<^sub>\<circ> S \<Longrightarrow> S\<lparr>a\<rparr> = T\<lparr>a\<rparr>" for a
      by (unfold dom_lhs, elim_in_numeral, insert assms)
        (auto simp: arr_field_simps)
  qed auto
qed

lemma (in arr_Rel) arr_Rel_def: "T = [T\<lparr>ArrVal\<rparr>, T\<lparr>ArrDom\<rparr>, T\<lparr>ArrCod\<rparr>]\<^sub>\<circ>"
proof(rule vsv_eqI)
  have dom_lhs: "\<D>\<^sub>\<circ> T = 3\<^sub>\<nat>" by (simp add: vfsequence_vdomain dg_Rel_cs_simps)
  have dom_rhs: "\<D>\<^sub>\<circ> [T\<lparr>ArrVal\<rparr>, T\<lparr>ArrDom\<rparr>, T\<lparr>ArrCod\<rparr>]\<^sub>\<circ> = 3\<^sub>\<nat>"
    by (simp add: nat_omega_simps)
  then show "\<D>\<^sub>\<circ> T = \<D>\<^sub>\<circ> [T\<lparr>ArrVal\<rparr>, T\<lparr>ArrDom\<rparr>, T\<lparr>ArrCod\<rparr>]\<^sub>\<circ>"
    unfolding dom_lhs dom_rhs by simp
  show "a \<in>\<^sub>\<circ> \<D>\<^sub>\<circ> T \<Longrightarrow> T\<lparr>a\<rparr> = [T\<lparr>ArrVal\<rparr>, T\<lparr>ArrDom\<rparr>, T\<lparr>ArrCod\<rparr>]\<^sub>\<circ>\<lparr>a\<rparr>" for a
    unfolding dom_lhs
    by elim_in_numeral (simp_all add: arr_field_simps nat_omega_simps)
qed (auto simp: vsv_axioms)

text\<open>Size.\<close>

lemma (in arr_Rel) arr_Rel_ArrVal_in_Vset: "T\<lparr>ArrVal\<rparr> \<in>\<^sub>\<circ> Vset \<alpha>"
proof-
  from arr_Rel_ArrVal_vdomain arr_Rel_ArrDom_in_Vset have
    "\<D>\<^sub>\<circ> (T\<lparr>ArrVal\<rparr>) \<in>\<^sub>\<circ> Vset \<alpha>"
    by auto
  moreover from arr_Rel_ArrVal_vrange arr_Rel_ArrCod_in_Vset have
    "\<R>\<^sub>\<circ> (T\<lparr>ArrVal\<rparr>) \<in>\<^sub>\<circ> Vset \<alpha>"
    by auto
  ultimately show "T\<lparr>ArrVal\<rparr> \<in>\<^sub>\<circ> Vset \<alpha>"
    by (simp add: ArrVal.vbrelation_Limit_in_VsetI)
qed

lemma (in arr_Rel) arr_Rel_in_Vset: "T \<in>\<^sub>\<circ> Vset \<alpha>"
proof-
  note [dg_Rel_cs_intros] =
    arr_Rel_ArrVal_in_Vset arr_Rel_ArrDom_in_Vset arr_Rel_ArrCod_in_Vset
  show ?thesis
    by (subst arr_Rel_def)
      (cs_concl cs_shallow cs_intro: dg_Rel_cs_intros V_cs_intros)
qed

lemma small_arr_Rel[simp]: "small {T. arr_Rel \<alpha> T}"
  by (rule down[of _ \<open>Vset \<alpha>\<close>]) (auto intro!: arr_Rel.arr_Rel_in_Vset)

text\<open>Other elementary properties.\<close>

lemma set_Collect_arr_Rel[simp]:
  "x \<in>\<^sub>\<circ> set (Collect (arr_Rel \<alpha>)) \<longleftrightarrow> arr_Rel \<alpha> x"
  by auto

lemma (in arr_Rel) arr_Rel_ArrVal_vsubset_ArrDom_ArrCod:
  "T\<lparr>ArrVal\<rparr> \<subseteq>\<^sub>\<circ> T\<lparr>ArrDom\<rparr> \<times>\<^sub>\<circ> T\<lparr>ArrCod\<rparr>"
proof
  fix ab assume "ab \<in>\<^sub>\<circ> T\<lparr>ArrVal\<rparr>"
  then obtain a b where "ab = \<langle>a, b\<rangle>"
    and "a \<in>\<^sub>\<circ> \<D>\<^sub>\<circ> (T\<lparr>ArrVal\<rparr>)"
    and "b \<in>\<^sub>\<circ> \<R>\<^sub>\<circ> (T\<lparr>ArrVal\<rparr>)"
    by (blast elim: ArrVal.vbrelation_vinE)
  with arr_Rel_ArrVal_vdomain arr_Rel_ArrVal_vrange show
    "ab \<in>\<^sub>\<circ> T\<lparr>ArrDom\<rparr> \<times>\<^sub>\<circ> T\<lparr>ArrCod\<rparr>"
    by auto
qed

subsubsection\<open>Composition\<close>

text\<open>See Chapter I-7 in \<^cite>\<open>"mac_lane_categories_2010"\<close>.\<close>

definition comp_Rel :: "V \<Rightarrow> V \<Rightarrow> V" (infixl \<open>\<circ>\<^sub>R\<^sub>e\<^sub>l\<close> 55)
  where "comp_Rel S T = [S\<lparr>ArrVal\<rparr> \<circ>\<^sub>\<circ> T\<lparr>ArrVal\<rparr>, T\<lparr>ArrDom\<rparr>, S\<lparr>ArrCod\<rparr>]\<^sub>\<circ>"

text\<open>Components.\<close>

lemma comp_Rel_components:
  shows "(S \<circ>\<^sub>R\<^sub>e\<^sub>l T)\<lparr>ArrVal\<rparr> = S\<lparr>ArrVal\<rparr> \<circ>\<^sub>\<circ> T\<lparr>ArrVal\<rparr>"
    and [dg_Rel_shared_cs_simps, dg_Rel_cs_simps]:
      "(S \<circ>\<^sub>R\<^sub>e\<^sub>l T)\<lparr>ArrDom\<rparr> = T\<lparr>ArrDom\<rparr>"
    and [dg_Rel_shared_cs_simps, dg_Rel_cs_simps]:
      "(S \<circ>\<^sub>R\<^sub>e\<^sub>l T)\<lparr>ArrCod\<rparr> = S\<lparr>ArrCod\<rparr>"
  unfolding comp_Rel_def arr_field_simps by (simp_all add: nat_omega_simps)

text\<open>Elementary properties.\<close>

lemma comp_Rel_vsv[dg_Rel_shared_cs_intros, dg_Rel_cs_intros]:
  "vsv (S \<circ>\<^sub>R\<^sub>e\<^sub>l T)"
  unfolding comp_Rel_def by auto

lemma arr_Rel_comp_Rel[dg_Rel_cs_intros]:
  assumes "arr_Rel \<alpha> S" and "arr_Rel \<alpha> T"
  shows "arr_Rel \<alpha> (S \<circ>\<^sub>R\<^sub>e\<^sub>l T)"
proof-
  interpret S: arr_Rel \<alpha> S by (rule assms(1))
  interpret T: arr_Rel \<alpha> T by (rule assms(2))
  show ?thesis
  proof(intro arr_RelI)
    show "vfsequence (S \<circ>\<^sub>R\<^sub>e\<^sub>l T)" unfolding comp_Rel_def by simp
    show "vcard (S \<circ>\<^sub>R\<^sub>e\<^sub>l T) = 3\<^sub>\<nat>"
      unfolding comp_Rel_def by (simp add: nat_omega_simps)
    from T.arr_Rel_ArrVal_vdomain show
      "\<D>\<^sub>\<circ> ((S \<circ>\<^sub>R\<^sub>e\<^sub>l T)\<lparr>ArrVal\<rparr>) \<subseteq>\<^sub>\<circ> (S \<circ>\<^sub>R\<^sub>e\<^sub>l T)\<lparr>ArrDom\<rparr>"
      unfolding comp_Rel_components by auto
    show "\<R>\<^sub>\<circ> ((S \<circ>\<^sub>R\<^sub>e\<^sub>l T)\<lparr>ArrVal\<rparr>) \<subseteq>\<^sub>\<circ> (S \<circ>\<^sub>R\<^sub>e\<^sub>l T)\<lparr>ArrCod\<rparr>"
      unfolding comp_Rel_components
    proof(intro vsubsetI)
      fix z assume "z \<in>\<^sub>\<circ> \<R>\<^sub>\<circ> (S\<lparr>ArrVal\<rparr> \<circ>\<^sub>\<circ> T\<lparr>ArrVal\<rparr>)"
      then obtain x y where "\<langle>y, z\<rangle> \<in>\<^sub>\<circ> S\<lparr>ArrVal\<rparr>" and "\<langle>x, y\<rangle> \<in>\<^sub>\<circ> T\<lparr>ArrVal\<rparr>"
        by (meson vcomp_obtain_middle vrange_iff_vdomain)
      with S.arr_Rel_ArrVal_vrange show "z \<in>\<^sub>\<circ> S\<lparr>ArrCod\<rparr>" by auto
    qed
  qed
    (
      auto simp:
        comp_Rel_components T.arr_Rel_ArrDom_in_Vset S.arr_Rel_ArrCod_in_Vset
    )
qed

lemma arr_Rel_comp_Rel_assoc[dg_Rel_shared_cs_simps, dg_Rel_cs_simps]:
  "(H \<circ>\<^sub>R\<^sub>e\<^sub>l G) \<circ>\<^sub>R\<^sub>e\<^sub>l F = H \<circ>\<^sub>R\<^sub>e\<^sub>l (G \<circ>\<^sub>R\<^sub>e\<^sub>l F)"
  by (simp add: comp_Rel_def vcomp_assoc arr_field_simps nat_omega_simps)

subsubsection\<open>Inclusion arrow\<close>

text\<open>
The definition of the inclusion arrow is based on the concept of the
inclusion map, e.g., see \<^cite>\<open>"noauthor_wikipedia_2001"\<close>\footnote{
\url{https://en.wikipedia.org/wiki/Inclusion_map}
}\<close>

definition "incl_Rel A B = [vid_on A, A, B]\<^sub>\<circ>"

text\<open>Components.\<close>

lemma incl_Rel_components:
  shows "incl_Rel A B\<lparr>ArrVal\<rparr> = vid_on A"
    and [dg_Rel_shared_cs_simps, dg_Rel_cs_simps]: "incl_Rel A B\<lparr>ArrDom\<rparr> = A"
    and [dg_Rel_shared_cs_simps, dg_Rel_cs_simps]: "incl_Rel A B\<lparr>ArrCod\<rparr> = B"
  unfolding incl_Rel_def arr_field_simps by (simp_all add: nat_omega_simps)

text\<open>Arrow value.\<close>

lemma incl_Rel_ArrVal_vsv[dg_Rel_shared_cs_intros, dg_Rel_cs_intros]:
  "vsv (incl_Rel A B\<lparr>ArrVal\<rparr>)"
  unfolding incl_Rel_components by simp

lemma incl_Rel_ArrVal_vdomain[dg_Rel_shared_cs_simps, dg_Rel_cs_simps]:
  "\<D>\<^sub>\<circ> (incl_Rel A B\<lparr>ArrVal\<rparr>) = A"
  unfolding incl_Rel_components by simp

lemma incl_Rel_ArrVal_app[dg_Rel_shared_cs_simps, dg_Rel_cs_simps]:
  assumes "a \<in>\<^sub>\<circ> A"
  shows "incl_Rel A B\<lparr>ArrVal\<rparr>\<lparr>a\<rparr> = a"
  using assms unfolding incl_Rel_components by simp

text\<open>Elementary properties.\<close>

lemma incl_Rel_vfsequence[dg_Rel_shared_cs_intros, dg_Rel_cs_intros]:
  "vfsequence (incl_Rel A B)"
  unfolding incl_Rel_def by simp

lemma incl_Rel_vcard[dg_Rel_shared_cs_simps, dg_Rel_cs_simps]:
  "vcard (incl_Rel A B) = 3\<^sub>\<nat>"
  unfolding incl_Rel_def incl_Rel_def by (simp add: nat_omega_simps)

lemma (in \<Z>) arr_Rel_incl_RelI:
  assumes "A \<in>\<^sub>\<circ> Vset \<alpha>" and "B \<in>\<^sub>\<circ> Vset \<alpha>" and "A \<subseteq>\<^sub>\<circ> B"
  shows "arr_Rel \<alpha> (incl_Rel A B)"
proof(intro arr_RelI)
  show "vfsequence (incl_Rel A B)" unfolding incl_Rel_def by simp
  show "vcard (incl_Rel A B) = 3\<^sub>\<nat>"
    unfolding incl_Rel_def by (simp add: nat_omega_simps)
qed (auto simp: incl_Rel_components assms)

subsubsection\<open>Identity\<close>

text\<open>See Chapter I-7 in \<^cite>\<open>"mac_lane_categories_2010"\<close>.\<close>

definition id_Rel :: "V \<Rightarrow> V"
  where "id_Rel A = incl_Rel A A"

text\<open>Components.\<close>

lemma id_Rel_components:
  shows "id_Rel A\<lparr>ArrVal\<rparr> = vid_on A"
    and [dg_Rel_shared_cs_simps, dg_Rel_cs_simps]: "id_Rel A\<lparr>ArrDom\<rparr> = A"
    and [dg_Rel_shared_cs_simps, dg_Rel_cs_simps]: "id_Rel A\<lparr>ArrCod\<rparr> = A"
  unfolding id_Rel_def incl_Rel_components by simp_all

text\<open>Elementary properties.\<close>

lemma id_Rel_vfsequence[dg_Rel_shared_cs_intros, dg_Rel_cs_intros]:
  "vfsequence (id_Rel A)"
  unfolding id_Rel_def by (simp add: dg_Rel_cs_intros)

lemma id_Rel_vcard[dg_Rel_shared_cs_simps, dg_Rel_cs_simps]:
  "vcard (id_Rel A) = 3\<^sub>\<nat>"
  unfolding id_Rel_def by (simp add: dg_Rel_cs_simps)

lemma (in \<Z>) arr_Rel_id_RelI:
  assumes "A \<in>\<^sub>\<circ> Vset \<alpha>"
  shows "arr_Rel \<alpha> (id_Rel A)"
  by (intro arr_RelI)
    (auto simp: id_Rel_components(1) assms dg_Rel_cs_intros dg_Rel_cs_simps)

lemma id_Rel_ArrVal_app[dg_Rel_shared_cs_simps, dg_Rel_cs_simps]:
  assumes "a \<in>\<^sub>\<circ> A"
  shows "id_Rel A\<lparr>ArrVal\<rparr>\<lparr>a\<rparr> = a"
  using assms unfolding id_Rel_components by simp

lemma arr_Rel_comp_Rel_id_Rel_left[dg_Rel_cs_simps]:
  assumes "arr_Rel \<alpha> F" and "F\<lparr>ArrCod\<rparr> = A"
  shows "id_Rel A \<circ>\<^sub>R\<^sub>e\<^sub>l F = F"
proof(rule arr_Rel_eqI [of \<alpha>])
  interpret F: arr_Rel \<alpha> F by (rule assms(1))
  from assms(2) have "A \<in>\<^sub>\<circ> Vset \<alpha>" by (auto intro: F.arr_Rel_ArrCod_in_Vset)
  with assms(1) show "arr_Rel \<alpha> (id_Rel A \<circ>\<^sub>R\<^sub>e\<^sub>l F)"
    by (blast intro: F.arr_Rel_id_RelI intro!: arr_Rel_comp_Rel)
  from assms(2) F.arr_Rel_ArrVal_vrange show
    "(id_Rel A \<circ>\<^sub>R\<^sub>e\<^sub>l F)\<lparr>ArrVal\<rparr> = F\<lparr>ArrVal\<rparr>"
    unfolding comp_Rel_components id_Rel_components by auto
qed
  (
    use assms(2) in
      \<open>auto simp: assms(1) comp_Rel_components id_Rel_components\<close>
  )

lemma arr_Rel_comp_Rel_id_Rel_right[dg_Rel_cs_simps]:
  assumes "arr_Rel \<alpha> F" and "F\<lparr>ArrDom\<rparr> = A"
  shows "F \<circ>\<^sub>R\<^sub>e\<^sub>l id_Rel A = F"
proof(rule arr_Rel_eqI[of \<alpha>])
  interpret F: arr_Rel \<alpha> F by (rule assms(1))
  from assms(2) have "A \<in>\<^sub>\<circ> Vset \<alpha>" by (auto intro: F.arr_Rel_ArrDom_in_Vset)
  with assms(1) show "arr_Rel \<alpha> (F \<circ>\<^sub>R\<^sub>e\<^sub>l id_Rel A)"
    by (blast intro: F.arr_Rel_id_RelI intro!: arr_Rel_comp_Rel)
  show "arr_Rel \<alpha> F" by (simp add: assms(1))
  from assms(2) F.arr_Rel_ArrVal_vdomain show
    "(F \<circ>\<^sub>R\<^sub>e\<^sub>l id_Rel A)\<lparr>ArrVal\<rparr> = F\<lparr>ArrVal\<rparr>"
    unfolding comp_Rel_components id_Rel_components by auto
qed (use assms(2) in \<open>auto simp: comp_Rel_components id_Rel_components\<close>)

subsubsection\<open>Converse\<close>

text\<open>
As mentioned in Chapter I-7 in \<^cite>\<open>"mac_lane_categories_2010"\<close>, the
category \<open>Rel\<close> is usually equipped with an additional structure that is
the operation of taking a converse of a relation.
The operation is meant to be used almost exclusively as part of
the dagger functor for \<open>Rel\<close>.
\<close>

definition converse_Rel :: "V \<Rightarrow> V" ("(_\<inverse>\<^sub>R\<^sub>e\<^sub>l)" [1000] 999)
  where "converse_Rel T = [(T\<lparr>ArrVal\<rparr>)\<inverse>\<^sub>\<circ>, T\<lparr>ArrCod\<rparr>, T\<lparr>ArrDom\<rparr>]\<^sub>\<circ>"

lemma converse_Rel_components:
  shows "T\<inverse>\<^sub>R\<^sub>e\<^sub>l\<lparr>ArrVal\<rparr> = (T\<lparr>ArrVal\<rparr>)\<inverse>\<^sub>\<circ>"
    and [dg_Rel_shared_cs_simps, dg_Rel_cs_simps]: "T\<inverse>\<^sub>R\<^sub>e\<^sub>l\<lparr>ArrDom\<rparr> = T\<lparr>ArrCod\<rparr>"
    and [dg_Rel_shared_cs_simps, dg_Rel_cs_simps]: "T\<inverse>\<^sub>R\<^sub>e\<^sub>l\<lparr>ArrCod\<rparr> = T\<lparr>ArrDom\<rparr>"
  unfolding converse_Rel_def arr_field_simps by (simp_all add: nat_omega_simps)

text\<open>Elementary properties.\<close>

lemma (in arr_Rel) arr_Rel_converse_Rel: "arr_Rel \<alpha> (T\<inverse>\<^sub>R\<^sub>e\<^sub>l)"
proof(rule arr_RelI, unfold converse_Rel_components)
  show "vfsequence (T\<inverse>\<^sub>R\<^sub>e\<^sub>l)" unfolding converse_Rel_def by simp
  show "vcard (T\<inverse>\<^sub>R\<^sub>e\<^sub>l) = 3\<^sub>\<nat>"
    unfolding converse_Rel_def by (simp add: nat_omega_simps)
qed
  (
    auto simp:
      converse_Rel_components(1)
      arr_Rel_ArrDom_in_Vset
      arr_Rel_ArrCod_in_Vset
      arr_Rel_ArrVal_vdomain
      arr_Rel_ArrVal_vrange
  )

lemmas [dg_Rel_cs_intros] =
  arr_Rel.arr_Rel_converse_Rel

lemma (in arr_Rel)
  arr_Rel_converse_Rel_converse_Rel[dg_Rel_shared_cs_simps, dg_Rel_cs_simps]:
  "(T\<inverse>\<^sub>R\<^sub>e\<^sub>l)\<inverse>\<^sub>R\<^sub>e\<^sub>l = T"
proof(rule arr_Rel_eqI)
  from arr_Rel_axioms show "arr_Rel \<alpha> ((T\<inverse>\<^sub>R\<^sub>e\<^sub>l)\<inverse>\<^sub>R\<^sub>e\<^sub>l)"
    by (cs_intro_step dg_Rel_cs_intros)+
qed (simp_all add: arr_Rel_axioms converse_Rel_components)

lemmas [dg_Rel_cs_simps] =
  arr_Rel.arr_Rel_converse_Rel_converse_Rel

lemma arr_Rel_converse_Rel_eq_iff[dg_Rel_cs_simps]:
  assumes "arr_Rel \<alpha> F" and "arr_Rel \<alpha> G"
  shows "F\<inverse>\<^sub>R\<^sub>e\<^sub>l = G\<inverse>\<^sub>R\<^sub>e\<^sub>l \<longleftrightarrow> F = G"
proof(rule iffI)
  show "F\<inverse>\<^sub>R\<^sub>e\<^sub>l = G\<inverse>\<^sub>R\<^sub>e\<^sub>l \<Longrightarrow> F = G"
    by (metis arr_Rel.arr_Rel_converse_Rel_converse_Rel assms)
qed simp

lemma arr_Rel_converse_Rel_comp_Rel[dg_Rel_cs_simps]:
  assumes "arr_Rel \<alpha> G" and "arr_Rel \<alpha> F"
  shows "(F \<circ>\<^sub>R\<^sub>e\<^sub>l G)\<inverse>\<^sub>R\<^sub>e\<^sub>l = G\<inverse>\<^sub>R\<^sub>e\<^sub>l \<circ>\<^sub>R\<^sub>e\<^sub>l F\<inverse>\<^sub>R\<^sub>e\<^sub>l"
proof(rule arr_Rel_eqI, unfold converse_Rel_components comp_Rel_components)
  from assms show "arr_Rel \<alpha> (G\<inverse>\<^sub>R\<^sub>e\<^sub>l \<circ>\<^sub>R\<^sub>e\<^sub>l F\<inverse>\<^sub>R\<^sub>e\<^sub>l)"
    by (cs_concl cs_shallow cs_intro: dg_Rel_cs_intros)
  from assms show "arr_Rel \<alpha> ((F \<circ>\<^sub>R\<^sub>e\<^sub>l G)\<inverse>\<^sub>R\<^sub>e\<^sub>l)"
    by (cs_intro_step dg_Rel_cs_intros)+
qed (simp_all add: vconverse_vcomp)

lemma (in \<Z>) arr_Rel_converse_Rel_id_Rel:
  assumes "c \<in>\<^sub>\<circ> Vset \<alpha>"
  shows "arr_Rel \<alpha> ((id_Rel c)\<inverse>\<^sub>R\<^sub>e\<^sub>l)"
  using assms \<Z>_axioms
  by (cs_concl cs_shallow cs_intro: dg_Rel_cs_intros arr_Rel_id_RelI)+

lemma (in \<Z>) arr_Rel_converse_Rel_id_Rel_eq_id_Rel[
    dg_Rel_shared_cs_simps, dg_Rel_cs_simps
    ]:
  assumes "c \<in>\<^sub>\<circ> Vset \<alpha>"
  shows "(id_Rel c)\<inverse>\<^sub>R\<^sub>e\<^sub>l = id_Rel c"
  by (rule arr_Rel_eqI[of \<alpha>], unfold converse_Rel_components id_Rel_components)
    (simp_all add: assms arr_Rel_id_RelI arr_Rel_converse_Rel_id_Rel)

lemmas [dg_Rel_shared_cs_simps, dg_Rel_cs_simps] =
  \<Z>.arr_Rel_converse_Rel_id_Rel_eq_id_Rel

lemma arr_Rel_comp_Rel_converse_Rel_left_if_v11[dg_Rel_cs_simps]:
  assumes "arr_Rel \<alpha> T"
    and "\<D>\<^sub>\<circ> (T\<lparr>ArrVal\<rparr>) = A"
    and "T\<lparr>ArrDom\<rparr> = A"
    and "v11 (T\<lparr>ArrVal\<rparr>)"
    and "A \<in>\<^sub>\<circ> Vset \<alpha>"
  shows "T\<inverse>\<^sub>R\<^sub>e\<^sub>l \<circ>\<^sub>R\<^sub>e\<^sub>l T = id_Rel A"
proof-
  interpret T: arr_Rel \<alpha> T by (rule assms(1))
  interpret v11: v11 \<open>T\<lparr>ArrVal\<rparr>\<close> by (rule assms(4))
  show ?thesis
    by (rule arr_Rel_eqI[of \<alpha>])
      (
        auto simp:
          converse_Rel_components
          comp_Rel_components
          id_Rel_components
          assms(1,3,5)
          arr_Rel.arr_Rel_converse_Rel
          arr_Rel_comp_Rel
          T.arr_Rel_id_RelI
          v11.v11_vcomp_vconverse[unfolded assms(2)]
      )
qed

lemma arr_Rel_comp_Rel_converse_Rel_right_if_v11[dg_Rel_cs_simps]:
  assumes "arr_Rel \<alpha> T"
    and "\<R>\<^sub>\<circ> (T\<lparr>ArrVal\<rparr>) = A"
    and "T\<lparr>ArrCod\<rparr> = A"
    and "v11 (T\<lparr>ArrVal\<rparr>)"
    and "A \<in>\<^sub>\<circ> Vset \<alpha>"
  shows "T \<circ>\<^sub>R\<^sub>e\<^sub>l T\<inverse>\<^sub>R\<^sub>e\<^sub>l = id_Rel A"
proof-
  interpret T: arr_Rel \<alpha> T by (rule assms(1))
  interpret v11: v11 \<open>T\<lparr>ArrVal\<rparr>\<close> by (rule assms(4))
  show ?thesis
    by (rule arr_Rel_eqI[of \<alpha>])
      (
        auto simp:
          assms(1,3,5)
          comp_Rel_components
          converse_Rel_components
          id_Rel_components
          v11.v11_vcomp_vconverse'[unfolded assms(2)]
          T.arr_Rel_id_RelI
          arr_Rel.arr_Rel_converse_Rel
          arr_Rel_comp_Rel
      )
qed

subsection\<open>\<open>Rel\<close> as a digraph\<close>

subsubsection\<open>Definition and elementary properties\<close>

definition dg_Rel :: "V \<Rightarrow> V"
  where "dg_Rel \<alpha> =
    [
      Vset \<alpha>,
      set {T. arr_Rel \<alpha> T},
      (\<lambda>T\<in>\<^sub>\<circ>set {T. arr_Rel \<alpha> T}. T\<lparr>ArrDom\<rparr>),
      (\<lambda>T\<in>\<^sub>\<circ>set {T. arr_Rel \<alpha> T}. T\<lparr>ArrCod\<rparr>)
    ]\<^sub>\<circ>"

text\<open>Components.\<close>

lemma dg_Rel_components:
  shows "dg_Rel \<alpha>\<lparr>Obj\<rparr> = Vset \<alpha>"
    and "dg_Rel \<alpha>\<lparr>Arr\<rparr> = set {T. arr_Rel \<alpha> T}"
    and "dg_Rel \<alpha>\<lparr>Dom\<rparr> = (\<lambda>T\<in>\<^sub>\<circ>set {T. arr_Rel \<alpha> T}. T\<lparr>ArrDom\<rparr>)"
    and "dg_Rel \<alpha>\<lparr>Cod\<rparr> = (\<lambda>T\<in>\<^sub>\<circ>set {T. arr_Rel \<alpha> T}. T\<lparr>ArrCod\<rparr>)"
  unfolding dg_Rel_def dg_field_simps by (simp_all add: nat_omega_simps)

subsubsection\<open>Object\<close>

lemma dg_Rel_Obj_iff: "x \<in>\<^sub>\<circ> dg_Rel \<alpha>\<lparr>Obj\<rparr> \<longleftrightarrow> x \<in>\<^sub>\<circ> Vset \<alpha>"
  unfolding dg_Rel_components by auto

subsubsection\<open>Arrow\<close>

lemma dg_Rel_Arr_iff[dg_Rel_cs_simps]: "x \<in>\<^sub>\<circ> dg_Rel \<alpha>\<lparr>Arr\<rparr> \<longleftrightarrow> arr_Rel \<alpha> x"
  unfolding dg_Rel_components by auto

subsubsection\<open>Domain\<close>

mk_VLambda dg_Rel_components(3)
  |vsv dg_Rel_Dom_vsv[dg_Rel_cs_intros]|
  |vdomain dg_Rel_Dom_vdomain[dg_Rel_cs_simps]|
  |app dg_Rel_Dom_app[unfolded set_Collect_arr_Rel, dg_Rel_cs_simps]|

lemma dg_Rel_Dom_vrange: "\<R>\<^sub>\<circ> (dg_Rel \<alpha>\<lparr>Dom\<rparr>) \<subseteq>\<^sub>\<circ> dg_Rel \<alpha>\<lparr>Obj\<rparr>"
  unfolding dg_Rel_components
  by (rule vrange_VLambda_vsubset, unfold set_Collect_arr_Rel) auto

subsubsection\<open>Codomain\<close>

mk_VLambda dg_Rel_components(4)
  |vsv dg_Rel_Cod_vsv[dg_Rel_cs_intros]|
  |vdomain dg_Rel_Cod_vdomain[dg_Rel_cs_simps]|
  |app dg_Rel_Cod_app[unfolded set_Collect_arr_Rel, dg_Rel_cs_simps]|

lemma dg_Rel_Cod_vrange: "\<R>\<^sub>\<circ> (dg_Rel \<alpha>\<lparr>Cod\<rparr>) \<subseteq>\<^sub>\<circ> dg_Rel \<alpha>\<lparr>Obj\<rparr>"
  unfolding dg_Rel_components
  by (rule vrange_VLambda_vsubset, unfold set_Collect_arr_Rel) auto

subsubsection\<open>Arrow with a domain and a codomain\<close>

text\<open>Rules.\<close>

lemma dg_Rel_is_arrI[dg_Rel_cs_intros]:
  assumes "arr_Rel \<alpha> S" and "S\<lparr>ArrDom\<rparr> = A" and "S\<lparr>ArrCod\<rparr> = B"
  shows "S : A \<mapsto>\<^bsub>dg_Rel \<alpha>\<^esub> B"
  using assms by (intro is_arrI, unfold dg_Rel_components) simp_all

lemma dg_Rel_is_arrD:
  assumes "S : A \<mapsto>\<^bsub>dg_Rel \<alpha>\<^esub> B"
  shows "arr_Rel \<alpha> S"
    and [dg_cs_simps]: "S\<lparr>ArrDom\<rparr> = A"
    and [dg_cs_simps]: "S\<lparr>ArrCod\<rparr> = B"
  using is_arrD[OF assms] unfolding dg_Rel_components by simp_all

lemma dg_Rel_is_arrE:
  assumes "S : A \<mapsto>\<^bsub>dg_Rel \<alpha>\<^esub> B"
  obtains "arr_Rel \<alpha> S" and "S\<lparr>ArrDom\<rparr> = A" and "S\<lparr>ArrCod\<rparr> = B"
  using is_arrD[OF assms] unfolding dg_Rel_components by simp_all

text\<open>Elementary properties.\<close>

lemma (in \<Z>) dg_Rel_incl_Rel_is_arr:
  assumes "A \<in>\<^sub>\<circ> Vset \<alpha>" and "B \<in>\<^sub>\<circ> Vset \<alpha>" and "A \<subseteq>\<^sub>\<circ> B"
  shows "incl_Rel A B : A \<mapsto>\<^bsub>dg_Rel \<alpha>\<^esub> B"
proof(rule dg_Rel_is_arrI)
  show "arr_Rel \<alpha> (incl_Rel A B)" by (intro arr_Rel_incl_RelI assms)
qed (simp_all add: incl_Rel_components)

lemma (in \<Z>) dg_Rel_incl_Rel_is_arr'[dg_Rel_cs_intros]:
  assumes "A \<in>\<^sub>\<circ> Vset \<alpha>"
    and "B \<in>\<^sub>\<circ> Vset \<alpha>"
    and "A \<subseteq>\<^sub>\<circ> B"
    and "A' = A"
    and "B' = B"
  shows "incl_Rel A B : A' \<mapsto>\<^bsub>dg_Rel \<alpha>\<^esub> B'"
  using assms(1-3) unfolding assms(4,5) by (rule dg_Rel_incl_Rel_is_arr)

lemmas [dg_Rel_cs_intros] = \<Z>.dg_Rel_incl_Rel_is_arr'

lemma dg_Rel_is_arr_ArrValE:
  assumes "T : A \<mapsto>\<^bsub>dg_Rel \<alpha>\<^esub> B" and "ab \<in>\<^sub>\<circ> T\<lparr>ArrVal\<rparr>"
  obtains a b
    where "ab = \<langle>a, b\<rangle>" and "a \<in>\<^sub>\<circ> \<D>\<^sub>\<circ> (T\<lparr>ArrVal\<rparr>)" and "b \<in>\<^sub>\<circ> \<R>\<^sub>\<circ> (T\<lparr>ArrVal\<rparr>)"
proof-
  note T = dg_Rel_is_arrD[OF assms(1)]
  then interpret T: arr_Rel \<alpha> T
    rewrites "T\<lparr>ArrDom\<rparr> = A" and "T\<lparr>ArrCod\<rparr> = B"
    by simp_all
  from assms(2) obtain a b
    where "ab = \<langle>a, b\<rangle>" and "a \<in>\<^sub>\<circ> \<D>\<^sub>\<circ> (T\<lparr>ArrVal\<rparr>)" and "b \<in>\<^sub>\<circ> \<R>\<^sub>\<circ> (T\<lparr>ArrVal\<rparr>)"
    by (blast elim: T.ArrVal.vbrelation_vinE)
  with that show ?thesis by simp
qed

subsubsection\<open>\<open>Rel\<close> is a digraph\<close>

lemma (in \<Z>) dg_Rel_Hom_vifunion_in_Vset:
  assumes "X \<in>\<^sub>\<circ> Vset \<alpha>" and "Y \<in>\<^sub>\<circ> Vset \<alpha>"
  shows "(\<Union>\<^sub>\<circ>A\<in>\<^sub>\<circ>X. \<Union>\<^sub>\<circ>B\<in>\<^sub>\<circ>Y. Hom (dg_Rel \<alpha>) A B) \<in>\<^sub>\<circ> Vset \<alpha>"
proof-
  define Q where
    "Q i = (if i = 0 then VPow (\<Union>\<^sub>\<circ>X \<times>\<^sub>\<circ> \<Union>\<^sub>\<circ>Y) else if i = 1\<^sub>\<nat> then X else Y)"
    for i
  have
    "{[r, A, B]\<^sub>\<circ> |r A B. r \<subseteq>\<^sub>\<circ> \<Union>\<^sub>\<circ>X \<times>\<^sub>\<circ> \<Union>\<^sub>\<circ>Y \<and> A \<in>\<^sub>\<circ> X \<and> B \<in>\<^sub>\<circ> Y} \<subseteq>
      elts (\<Prod>\<^sub>\<circ>i\<in>\<^sub>\<circ> set {0, 1\<^sub>\<nat>, 2\<^sub>\<nat>}. Q i)"
  proof(intro subsetI, unfold mem_Collect_eq, elim exE conjE)
    fix F r A B assume prems:
      "F = [r, A, B]\<^sub>\<circ>"
      "r \<subseteq>\<^sub>\<circ> \<Union>\<^sub>\<circ>X \<times>\<^sub>\<circ> \<Union>\<^sub>\<circ>Y"
      "A \<in>\<^sub>\<circ> X"
      "B \<in>\<^sub>\<circ> Y"
    show "F \<in>\<^sub>\<circ> (\<Prod>\<^sub>\<circ>i\<in>\<^sub>\<circ> set {0, 1\<^sub>\<nat>, 2\<^sub>\<nat>}. Q i)"
    proof(intro vproductI, unfold Ball_def; (intro allI impI)?)
      show "\<D>\<^sub>\<circ> F = set {0, 1\<^sub>\<nat>, 2\<^sub>\<nat>}"
        by (simp add: three prems(1) nat_omega_simps)
      fix i assume "i \<in>\<^sub>\<circ> set {0, 1\<^sub>\<nat>, 2\<^sub>\<nat>}"
      then consider \<open>i = 0\<close> | \<open>i = 1\<^sub>\<nat>\<close> | \<open>i = 2\<^sub>\<nat>\<close> by auto
      then show "F\<lparr>i\<rparr> \<in>\<^sub>\<circ> Q i" by cases (auto simp: Q_def prems nat_omega_simps)
    qed (auto simp: prems(1))
  qed
  moreover then have small[simp]:
    "small {[r, A, B]\<^sub>\<circ> | r A B. r \<subseteq>\<^sub>\<circ>\<Union>\<^sub>\<circ>X \<times>\<^sub>\<circ> \<Union>\<^sub>\<circ>Y \<and> A \<in>\<^sub>\<circ> X \<and> B \<in>\<^sub>\<circ> Y}"
    by (rule down)
  ultimately have
    "set {[r, A, B]\<^sub>\<circ> |r A B. r \<subseteq>\<^sub>\<circ> \<Union>\<^sub>\<circ>X \<times>\<^sub>\<circ> \<Union>\<^sub>\<circ>Y \<and> A \<in>\<^sub>\<circ> X \<and> B \<in>\<^sub>\<circ> Y} \<subseteq>\<^sub>\<circ>
      (\<Prod>\<^sub>\<circ>i\<in>\<^sub>\<circ> set {0, 1\<^sub>\<nat>, 2\<^sub>\<nat>}. Q i)"
    by auto
  moreover have "(\<Prod>\<^sub>\<circ>i\<in>\<^sub>\<circ> set {0, 1\<^sub>\<nat>, 2\<^sub>\<nat>}. Q i) \<in>\<^sub>\<circ> Vset \<alpha>"
  proof(rule Limit_vproduct_in_VsetI)
    show "set {0, 1\<^sub>\<nat>, 2\<^sub>\<nat>} \<in>\<^sub>\<circ> Vset \<alpha>"
      by (auto simp: three[symmetric] intro!: Axiom_of_Infinity)
    from assms(1,2) have "VPow (\<Union>\<^sub>\<circ>X \<times>\<^sub>\<circ> \<Union>\<^sub>\<circ>Y) \<in>\<^sub>\<circ> Vset \<alpha>"
      by (intro Limit_VPow_in_VsetI Limit_vtimes_in_VsetI) auto
    then show "Q i \<in>\<^sub>\<circ> Vset \<alpha>" if "i \<in>\<^sub>\<circ> set {0, 1\<^sub>\<nat>, 2\<^sub>\<nat>}" for i
      using that assms(1,2) unfolding Q_def by (auto simp: nat_omega_simps)
  qed auto
  moreover have
    "(\<Union>\<^sub>\<circ>A\<in>\<^sub>\<circ>X. \<Union>\<^sub>\<circ>B\<in>\<^sub>\<circ>Y. Hom (dg_Rel \<alpha>) A B) \<subseteq>\<^sub>\<circ>
      set {[r, A, B]\<^sub>\<circ> | r A B. r \<subseteq>\<^sub>\<circ>\<Union>\<^sub>\<circ>X \<times>\<^sub>\<circ> \<Union>\<^sub>\<circ>Y \<and> A \<in>\<^sub>\<circ> X \<and> B \<in>\<^sub>\<circ> Y}"
  proof(rule vsubsetI)
    fix F assume prems: "F \<in>\<^sub>\<circ> (\<Union>\<^sub>\<circ>A\<in>\<^sub>\<circ>X. \<Union>\<^sub>\<circ>B\<in>\<^sub>\<circ>Y. Hom (dg_Rel \<alpha>) A B)"
    then obtain A where A: "A \<in>\<^sub>\<circ> X" and F_b: "F \<in>\<^sub>\<circ> (\<Union>\<^sub>\<circ>B\<in>\<^sub>\<circ>Y. Hom (dg_Rel \<alpha>) A B)"
      unfolding vifunion_iff by auto
    then obtain B where B: "B \<in>\<^sub>\<circ> Y" and F_fba: "F \<in>\<^sub>\<circ> Hom (dg_Rel \<alpha>) A B"
      by fastforce
    then have "F : A \<mapsto>\<^bsub>dg_Rel \<alpha>\<^esub> B" by simp
    note F = dg_Rel_is_arrD[OF this]
    interpret F: arr_Rel \<alpha> F rewrites "F\<lparr>ArrDom\<rparr> = A" and "F\<lparr>ArrCod\<rparr> = B"
      by (intro F)+
    show "F \<in>\<^sub>\<circ> set {[r, A, B]\<^sub>\<circ> | r A B. r \<subseteq>\<^sub>\<circ>\<Union>\<^sub>\<circ>X \<times>\<^sub>\<circ> \<Union>\<^sub>\<circ>Y \<and> A \<in>\<^sub>\<circ> X \<and> B \<in>\<^sub>\<circ> Y}"
    proof(intro in_set_CollectI small exI conjI)
      from F.arr_Rel_def show "F = [F\<lparr>ArrVal\<rparr>, A, B]\<^sub>\<circ>" unfolding F(2,3) by simp
      from A B have "A \<times>\<^sub>\<circ> B \<subseteq>\<^sub>\<circ> \<Union>\<^sub>\<circ>X \<times>\<^sub>\<circ> \<Union>\<^sub>\<circ>Y" by auto
      moreover then have "F\<lparr>ArrVal\<rparr> \<subseteq>\<^sub>\<circ> A \<times>\<^sub>\<circ> B"
        by (auto simp: F.arr_Rel_ArrVal_vsubset_ArrDom_ArrCod)
      ultimately show "F\<lparr>ArrVal\<rparr> \<subseteq>\<^sub>\<circ> \<Union>\<^sub>\<circ>X \<times>\<^sub>\<circ> \<Union>\<^sub>\<circ>Y" by auto
    qed (intro A B)+
  qed
  ultimately show "(\<Union>\<^sub>\<circ>A\<in>\<^sub>\<circ>X. \<Union>\<^sub>\<circ>B\<in>\<^sub>\<circ>Y. Hom (dg_Rel \<alpha>) A B) \<in>\<^sub>\<circ> Vset \<alpha>" by blast
qed

lemma (in \<Z>) digraph_dg_Rel: "digraph \<alpha> (dg_Rel \<alpha>)"
proof(intro digraphI)
  show "vfsequence (dg_Rel \<alpha>)" unfolding dg_Rel_def by clarsimp
  show "vcard (dg_Rel \<alpha>) = 4\<^sub>\<nat>"
    unfolding dg_Rel_def by (simp add: nat_omega_simps)
  show "\<R>\<^sub>\<circ> (dg_Rel \<alpha>\<lparr>Dom\<rparr>) \<subseteq>\<^sub>\<circ> dg_Rel \<alpha>\<lparr>Obj\<rparr>" by (simp add: dg_Rel_Dom_vrange)
  show "\<R>\<^sub>\<circ> (dg_Rel \<alpha>\<lparr>Cod\<rparr>) \<subseteq>\<^sub>\<circ> dg_Rel \<alpha>\<lparr>Obj\<rparr>" by (simp add: dg_Rel_Cod_vrange)
qed (auto simp: dg_Rel_components dg_Rel_Hom_vifunion_in_Vset dg_Rel_Dom_vrange)

subsection\<open>Canonical dagger for \<open>Rel\<close>\<close>

text\<open>
Dagger categories are exposed explicitly later.
In the context of this section, the ``dagger'' is viewed merely as
an explicitly defined homomorphism. A definition of a dagger functor, upon
which the definition presented in this section is based, can be found in nLab
\<^cite>\<open>"noauthor_nlab_nodate"\<close>\footnote{\url{https://ncatlab.org/nlab/show/Rel})}.
This reference also contains the majority of the results that are presented
in this subsection.
\<close>

subsubsection\<open>Definition and elementary properties\<close>

definition dghm_dag_Rel :: "V \<Rightarrow> V" (\<open>\<dagger>\<^sub>D\<^sub>G\<^sub>.\<^sub>R\<^sub>e\<^sub>l\<close>)
  where "\<dagger>\<^sub>D\<^sub>G\<^sub>.\<^sub>R\<^sub>e\<^sub>l \<alpha> =
    [
      vid_on (dg_Rel \<alpha>\<lparr>Obj\<rparr>),
      VLambda (dg_Rel \<alpha>\<lparr>Arr\<rparr>) converse_Rel,
      op_dg (dg_Rel \<alpha>),
      dg_Rel \<alpha>
    ]\<^sub>\<circ>"

text\<open>Components.\<close>

lemma dghm_dag_Rel_components:
  shows "\<dagger>\<^sub>D\<^sub>G\<^sub>.\<^sub>R\<^sub>e\<^sub>l \<alpha>\<lparr>ObjMap\<rparr> = vid_on (dg_Rel \<alpha>\<lparr>Obj\<rparr>)"
    and "\<dagger>\<^sub>D\<^sub>G\<^sub>.\<^sub>R\<^sub>e\<^sub>l \<alpha>\<lparr>ArrMap\<rparr> = VLambda (dg_Rel \<alpha>\<lparr>Arr\<rparr>) converse_Rel"
    and "\<dagger>\<^sub>D\<^sub>G\<^sub>.\<^sub>R\<^sub>e\<^sub>l \<alpha>\<lparr>HomDom\<rparr> = op_dg (dg_Rel \<alpha>)"
    and "\<dagger>\<^sub>D\<^sub>G\<^sub>.\<^sub>R\<^sub>e\<^sub>l \<alpha>\<lparr>HomCod\<rparr> = dg_Rel \<alpha>"
  unfolding dghm_dag_Rel_def dghm_field_simps by (simp_all add: nat_omega_simps)

subsubsection\<open>Object map\<close>

mk_VLambda dghm_dag_Rel_components(1)[folded VLambda_vid_on]
  |vsv dghm_dag_Rel_ObjMap_vsv[dg_Rel_cs_intros]|
  |vdomain
    dghm_dag_Rel_ObjMap_vdomain[unfolded dg_Rel_components, dg_Rel_cs_simps]
  |
  |app dghm_dag_Rel_ObjMap_app[unfolded dg_Rel_components, dg_Rel_cs_simps]|

lemma dghm_dag_Rel_ObjMap_vrange[dg_cs_simps]: "\<R>\<^sub>\<circ> (\<dagger>\<^sub>D\<^sub>G\<^sub>.\<^sub>R\<^sub>e\<^sub>l \<alpha>\<lparr>ObjMap\<rparr>) = Vset \<alpha>"
  unfolding dghm_dag_Rel_components dg_Rel_components by simp

subsubsection\<open>Arrow map\<close>

mk_VLambda dghm_dag_Rel_components(2)
  |vsv dghm_dag_Rel_ArrMap_vsv[dg_Rel_cs_intros]|
  |vdomain dghm_dag_Rel_ArrMap_vdomain[dg_Rel_cs_simps]|
  |app dghm_dag_Rel_ArrMap_app[unfolded dg_Rel_cs_simps, dg_Rel_cs_simps]|

lemma dghm_dag_Rel_ArrMap_app_vdomain[dg_cs_simps]:
  assumes "T : A \<mapsto>\<^bsub>dg_Rel \<alpha>\<^esub> B"
  shows "\<D>\<^sub>\<circ> (\<dagger>\<^sub>D\<^sub>G\<^sub>.\<^sub>R\<^sub>e\<^sub>l \<alpha>\<lparr>ArrMap\<rparr>\<lparr>T\<rparr>\<lparr>ArrVal\<rparr>) = \<R>\<^sub>\<circ> (T\<lparr>ArrVal\<rparr>)"
proof-
  from assms interpret T: arr_Rel \<alpha> T by (simp add: dg_Rel_is_arrD)
  from dg_Rel_is_arrD(1)[OF assms] show ?thesis
    by (cs_concl cs_simp: dg_Rel_cs_simps V_cs_simps converse_Rel_components(1))
qed

lemma dghm_dag_Rel_ArrMap_app_vrange[dg_cs_simps]:
  assumes "T : A \<mapsto>\<^bsub>dg_Rel \<alpha>\<^esub> B"
  shows "\<R>\<^sub>\<circ> (\<dagger>\<^sub>D\<^sub>G\<^sub>.\<^sub>R\<^sub>e\<^sub>l \<alpha>\<lparr>ArrMap\<rparr>\<lparr>T\<rparr>\<lparr>ArrVal\<rparr>) = \<D>\<^sub>\<circ> (T\<lparr>ArrVal\<rparr>)"
proof-
  from assms interpret T: arr_Rel \<alpha> T by (simp add: dg_Rel_is_arrD)
  from dg_Rel_is_arrD(1)[OF assms] show ?thesis
    by (cs_concl cs_simp: dg_Rel_cs_simps V_cs_simps converse_Rel_components(1))
qed

lemma dghm_dag_Rel_ArrMap_app_iff[dg_cs_simps]:
  assumes "T : A \<mapsto>\<^bsub>dg_Rel \<alpha>\<^esub> B"
  shows "\<langle>a, b\<rangle> \<in>\<^sub>\<circ> \<dagger>\<^sub>D\<^sub>G\<^sub>.\<^sub>R\<^sub>e\<^sub>l \<alpha>\<lparr>ArrMap\<rparr>\<lparr>T\<rparr>\<lparr>ArrVal\<rparr> \<longleftrightarrow> \<langle>b, a\<rangle> \<in>\<^sub>\<circ> T\<lparr>ArrVal\<rparr>"
proof-
  from assms interpret T: arr_Rel \<alpha> T by (simp add: dg_Rel_is_arrD)
  note T = dg_Rel_is_arrD[OF assms]
  note [dg_Rel_cs_simps] = converse_Rel_components
  show ?thesis
  proof(intro iffI)
    assume prems: "\<langle>a, b\<rangle> \<in>\<^sub>\<circ> \<dagger>\<^sub>D\<^sub>G\<^sub>.\<^sub>R\<^sub>e\<^sub>l \<alpha>\<lparr>ArrMap\<rparr>\<lparr>T\<rparr>\<lparr>ArrVal\<rparr>"
    then have a: "a \<in>\<^sub>\<circ> \<D>\<^sub>\<circ> (\<dagger>\<^sub>D\<^sub>G\<^sub>.\<^sub>R\<^sub>e\<^sub>l \<alpha>\<lparr>ArrMap\<rparr>\<lparr>T\<rparr>\<lparr>ArrVal\<rparr>)"
      and b: "b \<in>\<^sub>\<circ> \<R>\<^sub>\<circ> (\<dagger>\<^sub>D\<^sub>G\<^sub>.\<^sub>R\<^sub>e\<^sub>l \<alpha>\<lparr>ArrMap\<rparr>\<lparr>T\<rparr>\<lparr>ArrVal\<rparr>)"
      by auto
    with assms have a: "a \<in>\<^sub>\<circ> \<R>\<^sub>\<circ> (T\<lparr>ArrVal\<rparr>)" and b: "b \<in>\<^sub>\<circ> \<D>\<^sub>\<circ> (T\<lparr>ArrVal\<rparr>)"
      by (simp_all add: dg_cs_simps)
    from prems T(1) have "\<langle>a, b\<rangle> \<in>\<^sub>\<circ> (T\<lparr>ArrVal\<rparr>)\<inverse>\<^sub>\<circ>"
      by (cs_prems cs_shallow cs_simp: dg_Rel_cs_simps)
    then show "\<langle>b, a\<rangle> \<in>\<^sub>\<circ> T\<lparr>ArrVal\<rparr>" by clarsimp
  next
    assume "\<langle>b, a\<rangle> \<in>\<^sub>\<circ> T\<lparr>ArrVal\<rparr>"
    then have "\<langle>a, b\<rangle> \<in>\<^sub>\<circ> (T\<lparr>ArrVal\<rparr>)\<inverse>\<^sub>\<circ>" by auto
    with T(1) show "\<langle>a, b\<rangle> \<in>\<^sub>\<circ> \<dagger>\<^sub>D\<^sub>G\<^sub>.\<^sub>R\<^sub>e\<^sub>l \<alpha>\<lparr>ArrMap\<rparr>\<lparr>T\<rparr>\<lparr>ArrVal\<rparr>"
      by (cs_concl cs_shallow cs_simp: dg_Rel_cs_simps)
  qed
qed

subsubsection\<open>Further properties\<close>

lemma dghm_dag_Rel_ArrMap_vrange[dg_Rel_cs_simps]:
  "\<R>\<^sub>\<circ> (\<dagger>\<^sub>D\<^sub>G\<^sub>.\<^sub>R\<^sub>e\<^sub>l \<alpha>\<lparr>ArrMap\<rparr>) = dg_Rel \<alpha>\<lparr>Arr\<rparr>"
proof(intro vsubset_antisym vsubsetI)
  interpret ArrMap: vsv \<open>\<dagger>\<^sub>D\<^sub>G\<^sub>.\<^sub>R\<^sub>e\<^sub>l \<alpha>\<lparr>ArrMap\<rparr>\<close>
    unfolding dghm_dag_Rel_components by simp
  fix T assume "T \<in>\<^sub>\<circ> \<R>\<^sub>\<circ> (\<dagger>\<^sub>D\<^sub>G\<^sub>.\<^sub>R\<^sub>e\<^sub>l \<alpha>\<lparr>ArrMap\<rparr>)"
  then obtain S where T_def: "T = \<dagger>\<^sub>D\<^sub>G\<^sub>.\<^sub>R\<^sub>e\<^sub>l \<alpha>\<lparr>ArrMap\<rparr>\<lparr>S\<rparr>"
    and S: "S \<in>\<^sub>\<circ> \<D>\<^sub>\<circ> (\<dagger>\<^sub>D\<^sub>G\<^sub>.\<^sub>R\<^sub>e\<^sub>l \<alpha>\<lparr>ArrMap\<rparr>)"
    by (blast dest: ArrMap.vrange_atD)
  from S show "T \<in>\<^sub>\<circ> dg_Rel \<alpha>\<lparr>Arr\<rparr>"
    by
      (
        simp add:
          T_def
          dghm_dag_Rel_components
          dg_Rel_components
          arr_Rel.arr_Rel_converse_Rel
      )
next
  interpret ArrMap: vsv \<open>\<dagger>\<^sub>D\<^sub>G\<^sub>.\<^sub>R\<^sub>e\<^sub>l \<alpha>\<lparr>ArrMap\<rparr>\<close>
    unfolding dghm_dag_Rel_components by simp
  fix T assume "T \<in>\<^sub>\<circ> dg_Rel \<alpha>\<lparr>Arr\<rparr>"
  then have "arr_Rel \<alpha> T" by (simp add: dg_Rel_components)
  then have "(T\<inverse>\<^sub>R\<^sub>e\<^sub>l)\<inverse>\<^sub>R\<^sub>e\<^sub>l = T" and "arr_Rel \<alpha> (T\<inverse>\<^sub>R\<^sub>e\<^sub>l)"
    by
      (
        auto simp:
          arr_Rel.arr_Rel_converse_Rel_converse_Rel arr_Rel.arr_Rel_converse_Rel
      )
  then have "\<dagger>\<^sub>D\<^sub>G\<^sub>.\<^sub>R\<^sub>e\<^sub>l \<alpha>\<lparr>ArrMap\<rparr>\<lparr>T\<inverse>\<^sub>R\<^sub>e\<^sub>l\<rparr> = T" "T\<inverse>\<^sub>R\<^sub>e\<^sub>l \<in>\<^sub>\<circ> \<D>\<^sub>\<circ> (\<dagger>\<^sub>D\<^sub>G\<^sub>.\<^sub>R\<^sub>e\<^sub>l \<alpha>\<lparr>ArrMap\<rparr>)"
    by (simp_all add: dg_Rel_components(2) dghm_dag_Rel_components(2))
  then show "T \<in>\<^sub>\<circ> \<R>\<^sub>\<circ> (\<dagger>\<^sub>D\<^sub>G\<^sub>.\<^sub>R\<^sub>e\<^sub>l \<alpha>\<lparr>ArrMap\<rparr>)" by blast
qed

lemma dghm_dag_Rel_ArrMap_app_is_arr:
  assumes "T : b \<mapsto>\<^bsub>dg_Rel \<alpha>\<^esub> a"
  shows
    "\<dagger>\<^sub>D\<^sub>G\<^sub>.\<^sub>R\<^sub>e\<^sub>l \<alpha>\<lparr>ArrMap\<rparr>\<lparr>T\<rparr> : \<dagger>\<^sub>D\<^sub>G\<^sub>.\<^sub>R\<^sub>e\<^sub>l \<alpha>\<lparr>ObjMap\<rparr>\<lparr>a\<rparr> \<mapsto>\<^bsub>dg_Rel \<alpha>\<^esub> \<dagger>\<^sub>D\<^sub>G\<^sub>.\<^sub>R\<^sub>e\<^sub>l \<alpha>\<lparr>ObjMap\<rparr>\<lparr>b\<rparr>"
proof(intro is_arrI)
  from assms have a: "a \<in>\<^sub>\<circ> Vset \<alpha>" and b: "b \<in>\<^sub>\<circ> Vset \<alpha>"
    unfolding dg_Rel_components by (fastforce simp: dg_Rel_components)+
  from assms have T: "arr_Rel \<alpha> T" by (auto simp: dg_Rel_is_arrD(1))
  then show dag_T: "\<dagger>\<^sub>D\<^sub>G\<^sub>.\<^sub>R\<^sub>e\<^sub>l \<alpha>\<lparr>ArrMap\<rparr>\<lparr>T\<rparr> \<in>\<^sub>\<circ> dg_Rel \<alpha>\<lparr>Arr\<rparr>"
    by (cs_concl cs_shallow cs_simp: dg_Rel_cs_simps cs_intro: dg_Rel_cs_intros)
  from a assms T show "dg_Rel \<alpha>\<lparr>Dom\<rparr>\<lparr>\<dagger>\<^sub>D\<^sub>G\<^sub>.\<^sub>R\<^sub>e\<^sub>l \<alpha>\<lparr>ArrMap\<rparr>\<lparr>T\<rparr>\<rparr> = \<dagger>\<^sub>D\<^sub>G\<^sub>.\<^sub>R\<^sub>e\<^sub>l \<alpha>\<lparr>ObjMap\<rparr>\<lparr>a\<rparr>"
    by
      (
        cs_concl cs_shallow
          cs_simp: dg_cs_simps dg_Rel_cs_simps cs_intro: dg_Rel_cs_intros
      )
  from b assms T show "dg_Rel \<alpha>\<lparr>Cod\<rparr>\<lparr>\<dagger>\<^sub>D\<^sub>G\<^sub>.\<^sub>R\<^sub>e\<^sub>l \<alpha>\<lparr>ArrMap\<rparr>\<lparr>T\<rparr>\<rparr> = \<dagger>\<^sub>D\<^sub>G\<^sub>.\<^sub>R\<^sub>e\<^sub>l \<alpha>\<lparr>ObjMap\<rparr>\<lparr>b\<rparr>"
    by
      (
        cs_concl cs_shallow
          cs_simp: dg_cs_simps dg_Rel_cs_simps cs_intro: dg_Rel_cs_intros
      )
qed

subsubsection\<open>Canonical dagger for \<open>Rel\<close> is a digraph isomorphism\<close>

lemma (in \<Z>) dghm_dag_Rel_is_iso_dghm:
  "\<dagger>\<^sub>D\<^sub>G\<^sub>.\<^sub>R\<^sub>e\<^sub>l \<alpha> : op_dg (dg_Rel \<alpha>) \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^sub>.\<^sub>i\<^sub>s\<^sub>o\<^bsub>\<alpha>\<^esub> dg_Rel \<alpha>"
proof(rule is_iso_dghmI)
  interpret digraph \<alpha> \<open>dg_Rel \<alpha>\<close> by (simp add: digraph_dg_Rel)
  show "\<dagger>\<^sub>D\<^sub>G\<^sub>.\<^sub>R\<^sub>e\<^sub>l \<alpha> : op_dg (dg_Rel \<alpha>) \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^bsub>\<alpha>\<^esub> dg_Rel \<alpha>"
  proof(rule is_dghmI, unfold dg_op_simps dghm_dag_Rel_components(3,4))
    show "vfsequence (\<dagger>\<^sub>D\<^sub>G\<^sub>.\<^sub>R\<^sub>e\<^sub>l \<alpha>)"
      unfolding dghm_dag_Rel_def by (simp add: nat_omega_simps)
    show "vcard (\<dagger>\<^sub>D\<^sub>G\<^sub>.\<^sub>R\<^sub>e\<^sub>l \<alpha>) = 4\<^sub>\<nat>"
      unfolding dghm_dag_Rel_def by (simp add: nat_omega_simps)
    fix T a b assume "T : b \<mapsto>\<^bsub>dg_Rel \<alpha>\<^esub> a"
    then show
      "\<dagger>\<^sub>D\<^sub>G\<^sub>.\<^sub>R\<^sub>e\<^sub>l \<alpha>\<lparr>ArrMap\<rparr>\<lparr>T\<rparr> : \<dagger>\<^sub>D\<^sub>G\<^sub>.\<^sub>R\<^sub>e\<^sub>l \<alpha>\<lparr>ObjMap\<rparr>\<lparr>a\<rparr> \<mapsto>\<^bsub>dg_Rel \<alpha>\<^esub> \<dagger>\<^sub>D\<^sub>G\<^sub>.\<^sub>R\<^sub>e\<^sub>l \<alpha>\<lparr>ObjMap\<rparr>\<lparr>b\<rparr>"
      by (rule dghm_dag_Rel_ArrMap_app_is_arr)
  qed (auto simp: dghm_dag_Rel_components intro: dg_cs_intros dg_op_intros)
  show "v11 (\<dagger>\<^sub>D\<^sub>G\<^sub>.\<^sub>R\<^sub>e\<^sub>l \<alpha>\<lparr>ArrMap\<rparr>)"
  proof
    (
      intro vsv.vsv_valeq_v11I,
      unfold dghm_dag_Rel_ArrMap_vdomain dg_Rel_Arr_iff
    )
    fix S T assume prems:
      "arr_Rel \<alpha> S"
      "arr_Rel \<alpha> T"
      "\<dagger>\<^sub>D\<^sub>G\<^sub>.\<^sub>R\<^sub>e\<^sub>l \<alpha>\<lparr>ArrMap\<rparr>\<lparr>S\<rparr> = \<dagger>\<^sub>D\<^sub>G\<^sub>.\<^sub>R\<^sub>e\<^sub>l \<alpha>\<lparr>ArrMap\<rparr>\<lparr>T\<rparr>"
    from prems show "S = T"
      by
        (
          auto simp:
            dg_Rel_components
            dg_Rel_cs_simps
            dghm_dag_Rel_ArrMap_app[OF prems(1)]
            dghm_dag_Rel_ArrMap_app[OF prems(2)]
        )
  qed (auto intro: dg_Rel_cs_intros)
  show "\<R>\<^sub>\<circ> (\<dagger>\<^sub>D\<^sub>G\<^sub>.\<^sub>R\<^sub>e\<^sub>l \<alpha>\<lparr>ArrMap\<rparr>) = dg_Rel \<alpha>\<lparr>Arr\<rparr>" by (simp add: dg_Rel_cs_simps)
qed (simp_all add: dghm_dag_Rel_components)

subsubsection\<open>Further properties of the canonical dagger\<close>

lemma (in \<Z>) dghm_cn_comp_dghm_dag_Rel_dghm_dag_Rel:
  "\<dagger>\<^sub>D\<^sub>G\<^sub>.\<^sub>R\<^sub>e\<^sub>l \<alpha> \<^sub>D\<^sub>G\<^sub>H\<^sub>M\<circ> \<dagger>\<^sub>D\<^sub>G\<^sub>.\<^sub>R\<^sub>e\<^sub>l \<alpha> = dghm_id (dg_Rel \<alpha>)"
proof-
  interpret digraph \<alpha> \<open>dg_Rel \<alpha>\<close> by (simp add: digraph_dg_Rel)
  from dghm_dag_Rel_is_iso_dghm have dag:
    "\<dagger>\<^sub>D\<^sub>G\<^sub>.\<^sub>R\<^sub>e\<^sub>l \<alpha> : dg_Rel \<alpha> \<^sub>D\<^sub>G\<mapsto>\<mapsto>\<^bsub>\<alpha>\<^esub> dg_Rel \<alpha>"
    by (simp add: is_iso_dghm_def)
  show ?thesis
  proof(rule dghm_eqI)
    show "(\<dagger>\<^sub>D\<^sub>G\<^sub>.\<^sub>R\<^sub>e\<^sub>l \<alpha> \<^sub>D\<^sub>G\<^sub>H\<^sub>M\<circ> \<dagger>\<^sub>D\<^sub>G\<^sub>.\<^sub>R\<^sub>e\<^sub>l \<alpha>)\<lparr>ArrMap\<rparr> = dghm_id (dg_Rel \<alpha>)\<lparr>ArrMap\<rparr>"
    proof(rule vsv_eqI)
      show "vsv ((\<dagger>\<^sub>D\<^sub>G\<^sub>.\<^sub>R\<^sub>e\<^sub>l \<alpha> \<^sub>D\<^sub>G\<^sub>H\<^sub>M\<circ> \<dagger>\<^sub>D\<^sub>G\<^sub>.\<^sub>R\<^sub>e\<^sub>l \<alpha>)\<lparr>ArrMap\<rparr>)"
        by (auto simp: dghm_cn_comp_components dghm_dag_Rel_components)
      fix a assume "a \<in>\<^sub>\<circ> \<D>\<^sub>\<circ> ((\<dagger>\<^sub>D\<^sub>G\<^sub>.\<^sub>R\<^sub>e\<^sub>l \<alpha> \<^sub>D\<^sub>G\<^sub>H\<^sub>M\<circ> \<dagger>\<^sub>D\<^sub>G\<^sub>.\<^sub>R\<^sub>e\<^sub>l \<alpha>)\<lparr>ArrMap\<rparr>)"
      then have a: "arr_Rel \<alpha> a"
        unfolding dg_Rel_cs_simps dghm_cn_comp_ArrMap_vdomain[OF dag dag] by simp
      from a dghm_dag_Rel_is_iso_dghm show
        "(\<dagger>\<^sub>D\<^sub>G\<^sub>.\<^sub>R\<^sub>e\<^sub>l \<alpha> \<^sub>D\<^sub>G\<^sub>H\<^sub>M\<circ> \<dagger>\<^sub>D\<^sub>G\<^sub>.\<^sub>R\<^sub>e\<^sub>l \<alpha>)\<lparr>ArrMap\<rparr>\<lparr>a\<rparr> = dghm_id (dg_Rel \<alpha>)\<lparr>ArrMap\<rparr>\<lparr>a\<rparr>"
        by
          (
            cs_concl
              cs_simp: dg_Rel_cs_simps dg_cs_simps dg_cn_cs_simps
              cs_intro: dg_Rel_cs_intros dghm_cs_intros
          )
    qed (simp_all add: dghm_cn_comp_components dghm_id_components dg_Rel_cs_simps)
    show "dghm_id (dg_Rel \<alpha>) : dg_Rel \<alpha> \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^bsub>\<alpha>\<^esub> dg_Rel \<alpha>"
      by (simp_all add: digraph.dg_dghm_id_is_dghm digraph_axioms)
  qed
    (
      auto simp:
        dghm_cn_comp_is_dghm[OF digraph_axioms dag dag]
        dghm_cn_comp_components
        dghm_dag_Rel_components
        dghm_id_components
    )
qed

text\<open>\newpage\<close>

end


theory word_aux
imports Word_Lib.Word_Lemmas_32 Word_Lib.WordSetup
begin
lemma unat_of_int_32[simp]: "0 \<le> i \<Longrightarrow> i \<le> 2 ^ 32 - 1 \<Longrightarrow> unat ((of_int i)::32 word) = nat i"
  unfolding unat_def
  apply (subst eq_nat_nat_iff, clarsimp+)
  apply (subst word_of_int)
  apply (subst uint_word_of_int)
  by simp

lemma takeWhile_take: "length (takeWhile P xs) \<le> n \<Longrightarrow> takeWhile P (take n xs) = takeWhile P xs"
proof (induction xs arbitrary:n rule:rev_induct)
  case (snoc x xs)
  show ?case
    apply (cases "n \<ge> length (xs @ [x])")
    apply (auto simp: not_le)
    apply (cases "list_all P xs")
    subgoal
      apply (auto simp: list_all_iff)
      using snoc(2)
      by auto
    subgoal
      using snoc takeWhile_append1
      by (metis list.pred_set)
    done
qed auto

lemma takeWhile_all: "length (takeWhile P xs) = length xs \<Longrightarrow> list_all P xs"
  by (simp add: list_all_length takeWhile_take_has_property_nth)

lemma word_is_zero: "word_of_int i = (0::'a::len0 word) \<Longrightarrow> i mod (2 ^ len_of TYPE('a)) = 0"
  by (metis uint_eq_0 word_uint.eq_norm)

lemma clz_shift_32_step':
  assumes "i > 0" "i \<le> 2 ^ 32 - 1"
  shows "word_clz (((of_int i)::32 word) >> 1) = word_clz ((of_int i)::32 word) + 1"
  unfolding word_clz_def
  apply (subst bl_shiftr)
  apply (auto simp: word_size)
using assms proof -
  assume "i > 0" "i \<le> 2 ^ 32 - 1"
  let ?r = "length (takeWhile Not (to_bl ((of_int i)::32 word)))" and
      ?l = "length (takeWhile Not (take 31 (to_bl ((of_int i)::32 word))))" and
      ?bl = "to_bl((of_int i)::32 word)"
  have "?r \<le> 32"
    using List.length_takeWhile_le[where xs = ?bl, unfolded word_size_bl[symmetric]]
    by (simp add: word_size)
  moreover have "?r \<noteq> 32"
  proof (rule ccontr, simp)
    assume "?r = 32"
    also have "length ?bl = 32"
      by (simp add: word_size)
    finally have "list_all Not ?bl"
      using takeWhile_all by metis
    then have "True \<notin> set ?bl"
      by (metis Ball_set_list_all)
    then have "((of_int i)::32 word) = 0"
      using eq_zero_set_bl by blast
    with \<open>i > 0\<close> \<open>i \<le> _\<close> show False
      apply -
      apply (subst (asm) word_of_int)
      apply (drule word_is_zero)
      by auto
  qed
  ultimately have "?r \<le> 31"
    by simp
  from takeWhile_take[OF this]
  show "?l = ?r"
    by simp
qed

lemma clz_shift_32_step:
  assumes "i > 0" "i \<le> 2 ^ 32 - 1" (* i \<le> 2 ^ 32 - 1 is necessary *)
  shows "word_clz ((of_int (i div 2))::32 word) = word_clz ((of_int i)::32 word) + 1"
  using clz_shift_32_step'[OF assms]
  apply -
  apply (subst (asm) shiftr1_is_div_2[of "(of_int i)::32 word"])
  unfolding word_div_def
  apply (subst (asm) word_of_int)
  apply (subst (asm) uint_word_of_int)
  apply (subst word_of_int)
  unfolding word_of_int_def
  using assms
  by auto

lemma int_le_trans: "i \<le> (j::int) \<Longrightarrow> j \<le> k \<Longrightarrow> i \<le> k" (* could be removed *)
  by simp

lemma div_mult2_eq': "b \<ge> 0 \<Longrightarrow> a div (b * c) = (a div c) div (b::int)"
  by (smt zdiv_zmult2_eq mult.commute)

lemma zdiv_le_dividend': "m \<ge> 0 \<Longrightarrow> m div n \<le> (m::int)"
  by (smt nonneg1_imp_zdiv_pos_iff zdiv_le_dividend)

lemma clz_shift_32: "i \<ge> 2 ^ n \<Longrightarrow> i \<le> 2 ^ 32 - 1 \<Longrightarrow> word_clz ((of_int i)::32 word) = word_clz ((of_int (i div 2 ^ n))::32 word) - n"
proof (induction n)
  fix n
  assume IH: "(2::int) ^ (n::nat) \<le> i \<Longrightarrow> i \<le> 2 ^ 32 - 1 \<Longrightarrow> word_clz ((of_int i)::32 word) = word_clz ((of_int (i div (2::int) ^ n))::32 word) - n"
     and prem: "(2::int) ^ Suc n \<le> i" "i \<le> 2 ^ 32 - 1"
  from prem have "i > 0"
    using less_le_trans zless2p by blast
  have "word_clz ((of_int i)::32 word) = word_clz ((of_int (i div (2::int) ^ n))::32 word) - n"
    apply (rule IH)
    apply (rule int_le_trans)
    defer
    apply (rule prem)+
    by simp
  also have "... = word_clz ((of_int (i div (2::int) ^ Suc n))::32 word) - Suc n"
    apply simp
    apply (subst div_mult2_eq', simp)
    apply (subst clz_shift_32_step)
    using \<open>i > 0\<close> pos_imp_zdiv_pos_iff prem
    apply auto
    using zdiv_le_dividend'[of i]
    by smt
  finally show "word_clz ((of_int i)::32 word) = word_clz ((of_int (i div (2::int) ^ Suc n))::32 word) - Suc n"
    by auto
qed auto

thm word_eq_iff word_ops_nth_size
thm bin_nth_ops
thm word_eqI
thm uminus_word.abs_eq
thm unat_of_nat
thm bintrunc_mod2p

thm bin_add_not
thm bin_induct

lemma of_int_sign: "(of_int i::'a::len word) !! n = (of_int i::'a signed word) !! n"
proof (induction i arbitrary:n rule: bin_induct)
  case (3 bin bit)
  then show ?case
    apply -
    unfolding test_bit_wi word_of_int
    by (cases bit, auto)
qed auto

lemma uint_of_nat:
	"uint (of_nat x :: 'a::len word) = (int x) mod 2^ len_of TYPE('a)"
	apply (clarsimp simp only: uint_nat unat_of_nat)
  apply (metis of_nat_numeral semiring_1_class.of_nat_power zmod_int)
  done

definition ls_bit :: "'a :: len  word \<Rightarrow> nat option" where
"ls_bit w = (if w = 0 then None else
            (Some (THE n. test_bit w n \<and> (\<forall>i < n. \<not>test_bit w i))))"

lemma ls_bit_1: "ls_bit 1 = Some 0"
  unfolding ls_bit_def
  by auto

lemma ls_bit_signed: "ls_bit (of_int i::'a::len word) = ls_bit (of_int i::'a::len signed word)"
  unfolding ls_bit_def
  apply (split if_splits)
  apply (intro conjI impI)
   apply (split if_splits)
   apply (intro conjI impI refl)
  apply (metis (full_types) nth_0 of_int_sign word_exists_nth)
  apply (split if_splits)
  apply (intro conjI impI)
   apply (metis (full_types) nth_0 of_int_sign word_exists_nth)
  apply (rule arg_cong[where f = Some])
  by (meson of_int_sign)

lemma ls_bit_not_zero:"w\<noteq>0 \<Longrightarrow> \<exists>n. ls_bit w = Some n"
  unfolding ls_bit_def by auto

lemma ls_bit_exists:"(w::'a :: len  word ) \<noteq> 0 \<Longrightarrow> \<exists>n. test_bit w n \<and> (\<forall>i < n. \<not>test_bit w i)"
proof (rule ccontr)
  assume a0:"w\<noteq>0"
  assume a1:"\<nexists>n. w !! n \<and> (\<forall>i<n. \<not> w !! i)"
  then show False using word_exists_nth[OF a0] a1 by (meson  exists_least_iff)
qed

lemma ls_bit_unique:"test_bit w n \<and> (\<forall>i < n. \<not>test_bit w i) \<Longrightarrow>
                     test_bit w n1 \<and> (\<forall>i < n1. \<not>test_bit w i) \<Longrightarrow>
                     n=n1"
  using nat_neq_iff by blast

lemma ls_bit_Some_not_zero:"ls_bit w = Some n \<Longrightarrow> w\<noteq>0"
  unfolding ls_bit_def by auto

lemma ls_bit_p:
  assumes a0:"ls_bit w = Some n"
  shows"test_bit w n \<and> (\<forall>i < n. \<not>test_bit w i)"
proof-
  have u:"\<exists>!n. test_bit w n \<and> (\<forall>i < n. \<not>test_bit w i)"
    using ls_bit_exists[OF ls_bit_Some_not_zero[OF a0]] ls_bit_unique by auto
  thus ?thesis using ls_bit_Some_not_zero[OF a0] theI'[OF u]
      a0[simplified ls_bit_def ls_bit_Some_not_zero[OF a0] if_False]
    by blast
qed

lemma ls_bit_less_length:"ls_bit w = Some n \<Longrightarrow> n < size w"
  by (fastforce dest: ls_bit_p simp :test_bit_size)

lemma power_ls_bit: "n < len_of TYPE('a::len) \<Longrightarrow> ls_bit ((2::'a::len word) ^ n) = Some n"
  unfolding ls_bit_def
  apply (rule the1I2)
  apply (auto simp:nth_w2p)
  done

declare[[show_types]]
lemma ls_bit_NOT:
  assumes a0:"ls_bit w = Some m" and
          a1:"w' = ( NOT w)"
  shows "\<not> test_bit w' m \<and> (\<forall>i < m. test_bit w' i)"
proof-
  have ls_bit:"test_bit w m \<and> (\<forall>i < m. \<not>test_bit w i)"
    using ls_bit_p[OF a0] by auto
  then have "\<not> test_bit w' m" using a1
    by (simp add: test_bit_size word_ops_nth_size)
  moreover have "(\<forall>i < m. test_bit w' i)"
  proof-
    {fix i
      assume a00:"i<m"
      then have "\<not> test_bit w i" using conjunct2[OF ls_bit] by auto
      then have "test_bit w' i" using test_bit_size
        by (metis a00 a1 dual_order.strict_trans ls_bit word_ops_nth_size)
    } thus ?thesis by auto
  qed
  ultimately show ?thesis by auto
qed

lemma eqFalseI: "\<not>P \<Longrightarrow> P = False"
  by simp

lemma bin_plus_one_1:
  assumes "\<not> bin_nth b m" and "\<forall>i<m. bin_nth b i"
  shows "bin_nth (b + (1::int)) m"
  using assms proof (induction b arbitrary :m rule: bin_induct)
  case (3 bin bit)
  show ?case
  proof (cases bit)
    {
      case False
      with 3 have "m = 0"
        using bin_nth_0_BIT by blast
      with False show ?thesis
        by auto
    next
      case True
      with 3 have "\<not> bin_nth bin (m-1)" "\<forall>i<(m-1). bin_nth bin i"
        apply (auto simp: bin_nth_Bit)
        by (metis (no_types) "3.prems"(2) add.right_neutral add_Suc_right bin_nth_Suc_BIT less_diff_conv)
      with 3 have "bin_nth (bin + 1) (m - 1)"
        by blast
      with True show ?thesis
        by (metis (mono_tags, lifting) "3.prems"(1) bin_nth_0_BIT bin_nth_minus not_gr_zero succ_BIT_simps(2))
    }
  qed
qed auto

lemma bin_plus_one_2:
  assumes "\<forall>i<m. bin_nth b i"and " i < m"
  shows " \<not> bin_nth (b + (1::int)) i"
using assms proof (induction b arbitrary:m i rule: bin_induct)
  case (3 bin bit)
  show ?case
  proof (cases bit)
    {
      case False
      with 3 have "m = 0"
        using bin_nth_0_BIT by blast
      with 3 show ?thesis
        by simp
    next
      case True
      with 3 have "\<forall>i<(m-1). bin_nth bin i"
        using less_diff_conv by auto
      with 3 have "\<forall>i < (m-1). \<not> bin_nth (bin + 1) i"
        by blast
      from True have "bit = True" by simp
      show ?thesis
        unfolding \<open>bit = _\<close>
        apply auto
        apply (cases i, auto)
        apply (subgoal_tac "nat < (m - 1)")
        using \<open>\<forall>i < (m-1). \<not> bin_nth _ _\<close>
         apply blast
        using \<open>i < m\<close>
        by simp
    }
  qed
qed auto

lemma bin_plus_one_3:
  assumes "\<not> bin_nth w m" and "i > m"
  shows "bin_nth (w+1) i = bin_nth w i"
  using assms proof (induction w arbitrary: i m rule:bin_induct)
  case (3 bin bit)
  show ?case
  proof (cases bit)
    {
      case True
      with 3 have "m \<noteq> 0"
        by (meson bin_nth_0_BIT)
      with 3 have " \<not> bin_nth bin (m-1)"
        using bin_nth_minus by blast
      with 3 have "\<forall>i > (m-1).bin_nth (bin + 1) i = bin_nth bin i"
        by blast
      show ?thesis
        unfolding True[THEN eqTrueI]
        unfolding succ_BIT_simps
        apply (cases i)
        using \<open>i > m\<close> apply blast
        apply simp
        using \<open>i > m\<close> \<open>\<forall>i > (m-1).bin_nth _ _ = _\<close> \<open>(m::nat) \<noteq> (0::nat)\<close>
        by auto
    next
      case False
      show ?thesis
        unfolding \<open>\<not>bit\<close>[THEN eqFalseI]
        unfolding succ_BIT_simps
        apply (cases i)
        using \<open>i > m\<close> apply blast
        by simp
    }
  qed
qed auto

lemma ls_bit_SUCC:
  assumes "\<not> (w::'a::len word) !! m \<and> (\<forall>i < m. w !! i)" and
          "m < len_of TYPE('a::len)"
  shows "(w+1) !! m \<and> (\<forall>i < m. \<not> (w+1) !! i) \<and> (\<forall>i > m. (w+1) !! i = w !! i)"
  using assms apply transfer
  apply (auto simp: bin_plus_one_1 bin_plus_one_2 bin_plus_one_3)
  done
lemma word_and_complement':
  assumes "n < size w" and "w\<noteq>0"
  shows "((w::'a::len word) && - w) !! n = ((2::'a::len word) ^ the (ls_bit w)) !! n"
proof-
  obtain m where "ls_bit w = Some m" "the (ls_bit w) = m"
    using ls_bit_not_zero[OF \<open>w\<noteq>0\<close>] by auto
  then have "w !! m" "(\<forall>i < m. \<not> w !! i)"
    using ls_bit_p by auto
  hence "m < size w"
    by (simp add: test_bit_size)
  have "\<not> (NOT w)!! m" "(\<forall>i < m.(NOT w) !!i)"
    using ls_bit_NOT[OF \<open>ls_bit w = _\<close>] by auto
  hence "(- w) !! m " "(\<forall>i < m. \<not>(- w) !! i)" "\<forall>i > m. (- w) !! i = (NOT w) !! i"
    unfolding twos_complement
    unfolding word_succ_p1
    using ls_bit_SUCC \<open>m < _\<close>
    by (metis word_size)+
  with \<open>w !! m\<close> \<open>(\<forall>i < m. \<not> w !! i)\<close>
  have "(w && -w) !! m"  "(\<forall>i < m. \<not> (w && -w) !! i)"
    using word_ops_nth_size[OF \<open>m < _\<close>] by force+
  moreover from \<open>\<forall>i > m. (- w) !! i = (NOT w) !! i\<close>
  have "\<forall>i > m. \<not> (w && - w) !! i"
    by (metis test_bit_bin word_ops_nth_size wsst_TYs(3))
  moreover have "((2::'a::len word) ^ m) !! m"
    using nth_w2p_same  \<open>m < _\<close>
    by (auto simp: word_size)
  moreover have "\<forall>i \<noteq> m. \<not>((2::'a::len word) ^ m) !! i"
    by (simp add: nth_w2p)
  ultimately have "(w && -w) !! n = ((2::'a::len word) ^ m) !! n"
    by (metis (full_types) linorder_neqE_nat)
  thus ?thesis unfolding \<open>the _ = _\<close> .
qed

declare[[coercion uint]]
value "bin_nth (4::4 word) 1"

lemma word_and_complement: "w \<noteq> 0 \<Longrightarrow> (w::('a :: len) word) && - w = 2 ^ (the (ls_bit w))"
  apply (subst word_eq_iff)
  using word_and_complement'
  by (auto simp: word_size)

lemma power_ge1: "(2::nat) ^ n \<ge> 1"
  by simp

(* looks awful *)
lemma table_2_power: "(2::nat) ^ i \<le> 255 \<Longrightarrow> table.[2 ^ i] = of_int i"
  apply (cases i)
   apply (auto simp: table_simp)
  apply (case_tac nat)
   apply (auto simp: table_simp)
  apply (case_tac nata)
   apply (auto simp: table_simp)
  apply (case_tac nat)
   apply (auto simp: table_simp)
  apply (case_tac nata)
   apply (auto simp: table_simp)
  apply (case_tac nat)
   apply (auto simp: table_simp)
  apply (case_tac nata)
   apply (auto simp: table_simp)
  apply (case_tac nat)
   apply (auto simp: table_simp)
  using power_ge1
  using not_less_eq_eq by fastforce

lemma word_is_not_zeroI: " i mod (2 ^ len_of TYPE('a)) \<noteq> 0 \<Longrightarrow> word_of_int i \<noteq> (0::'a::len0 word)"
  by (metis uint_eq_0 word_uint.eq_norm)

lemma power_msb: "msb ((2 ::'a::len signed word) ^ n) = (n+1 = len_of TYPE('a))"
  by (auto simp: msb_nth nth_w2p)

lemma ls_bit_lower_bound: "ls_bit w = Some m \<Longrightarrow> w \<ge> 2 ^ m"
  by (fastforce dest:ls_bit_p intro:bang_is_le)

lemma mod_le_simp:"i> 0 \<Longrightarrow> i < m \<Longrightarrow> i mod m = (i::int)"
  by simp
lemma uint_2: "len_of TYPE('a) > 1 \<Longrightarrow> uint (2::'a::len word) = 2"
  by (metis (no_types) Euclidean_Division.mod_less le_def len_gt_0 mod2_gr_0 nat_neq_iff uint_2_id)
lemma the_some: "a = Some b \<Longrightarrow> the a = b"
  by simp

lemma ls_bit_less_length': "w \<noteq> 0 \<Longrightarrow> the (ls_bit (w :: 'a::len word)) < len_of TYPE('a)"
  unfolding ls_bit_def
  apply auto
  by (metis (mono_tags) ls_bit_def ls_bit_p test_bit_bin)

lemma ls_bit_less_power:
  assumes "i > 0" "(i::int) \<le> 2 ^ m - 1"
          "m \<le> len_of TYPE('a)"
        shows "the (ls_bit ((of_int i)::'a::len word)) < m"
proof (cases "len_of TYPE('a) > 1")
  case True
  show ?thesis
  proof -
    have "i < 2 ^ len_of TYPE('a)"
      using assms
      by (smt power_increasing)
    obtain n where "ls_bit ((of_int i)::'a::len word) = Some n"
      apply atomize_elim
      apply (rule ls_bit_not_zero)
      apply (subst word_of_int)
      apply (rule word_is_not_zeroI)
      using assms
      by (smt int_mod_eq power_increasing)
    hence *:"((of_int i)::'a::len word) \<ge> 2 ^ n"
      using ls_bit_lower_bound by blast
    from * have "i \<ge> 2 ^ n"
      apply -
      apply (subst (asm) word_arith_power_alt)
      apply (subst (asm) word_of_int)
      apply (subst (asm) wi_le)
      apply (subst (asm) mod_le_simp[OF \<open>i > 0\<close> \<open>i < 2 ^ _\<close>])
      apply (subst (asm) uint_2[OF True])
      using ls_bit_less_length[OF \<open> _ = Some _\<close>]
      by (simp add: word_size)
    with \<open>i \<le> _ - 1\<close> have "n < m"
      by (smt power_less_imp_less_exp)
    thus ?thesis unfolding the_some[OF \<open>_ = Some n\<close>, symmetric] .
  qed
next
  case False
  hence "LENGTH('a) = 0 \<or> LENGTH('a) = 1"
    by linarith
  with assms have "m = 0 \<or> m = 1"
    by auto
  thus ?thesis
    using assms
    apply auto
    by (smt of_int_1 tlsf.the_some ls_bit_1)
qed

lemma p_ge_8: "2 ^ p > (255::nat) \<Longrightarrow> p \<ge> 8" (* could be proved easier *)
  apply (rule ccontr)
  apply (drule not_le_imp_less)
  using power_strict_increasing[of p 8 "2::nat"]
  by force
lemma p_ge_16: "2 ^ p > (65535::nat) \<Longrightarrow> p \<ge> 16"
  apply (rule ccontr)
  apply (drule not_le_imp_less)
  using power_strict_increasing[of p 16 "2::nat"]
  by force
lemma p_ge_24: "2 ^ p > (16777215::nat) \<Longrightarrow> p \<ge> 24"
  apply (rule ccontr)
  apply (drule not_le_imp_less)
  using power_strict_increasing[of p 24 "2::nat"]
  by force

thm word_of_int_power_hom
thm word_arith_power_alt

lemma ls_bit_correct_8:
  assumes "(0::int) < i" "i \<le> (2147483647::int)"
    "nat (sint ((of_int i::32 sword) && - of_int i)) \<le> (65535::nat)"
    "(255::nat) < nat (sint ((of_int i::32 sword) && - of_int i))"
  shows "sint (table.[unat ((of_int (sint ((of_int i::32 sword) && - of_int i))::32 word) >> (8::nat))]) + (8::int)
         = int (the (ls_bit (of_int i::32 word)))"
proof -
    let ?ls = "the (ls_bit ((of_int i)::32 sword))"
    from assms(1-2) have "of_int i \<noteq> (0::32 sword)"
      by (auto simp:word_of_int word_is_not_zeroI)
    from assms(1-2) have "?ls < 31"
      by (auto intro: ls_bit_less_power)
    hence "?ls < LENGTH (32 signed)"
      by simp
    from \<open>?ls < 31\<close> have "2 ^ ?ls < (2::int) ^ 31"
      by (metis numeral_One numeral_less_iff power_strict_increasing_iff semiring_norm(76))
    have "256 = (2::nat) ^ 8"
      by eval
    from assms(4) have "?ls \<ge> 8"
      unfolding word_and_complement[OF \<open>_ \<noteq> 0\<close>]
      unfolding word_sint_msb_eq power_msb
      using \<open>?ls < 31\<close>
      apply auto
      unfolding unat_def[symmetric]
      apply auto
      by (rule p_ge_8)
    from assms(3) have " (2::nat) ^ (?ls - (8::nat)) \<le> (255::nat)"
      unfolding word_and_complement[OF \<open>_ \<noteq> 0\<close>]
      unfolding word_sint_msb_eq power_msb
      using \<open>?ls < 31\<close>
      apply auto
      unfolding unat_def[symmetric]
      by (subst power_diff[OF _ \<open>?ls \<ge> 8\<close>], auto)
    show ?thesis
      unfolding word_and_complement[OF \<open>of_int i \<noteq> _\<close>]
      apply (subst (2) word_sint_msb_eq)
      unfolding power_msb
      using \<open>the _ < 31\<close>
      apply simp
      apply (subst word_arith_power_alt)
      apply (subst word_ubin.eq_norm)
      unfolding bintrunc_mod2p
      apply simp
      apply (subst mod_le_simp)
      apply simp
      using \<open>2 ^ ?ls < _\<close>
      apply simp
      apply simp
      unfolding shiftr_div_2n'
      apply simp
      unfolding \<open>256 = _\<close>
      thm power_diff
      apply (subst power_diff[symmetric])
      using \<open>?ls \<ge> 8\<close> apply auto
      unfolding table_2_power[OF \<open>_ \<le> 255\<close>]
      apply(auto simp:sint_word_ariths)
      unfolding word_of_nat
      unfolding word_sbin.eq_norm
      using \<open>?ls \<ge> 8\<close> \<open>?ls < 31\<close>
      apply (auto simp:sbintrunc_mod2p)
      using ls_bit_signed by metis
  qed

lemma ls_bit_correct_16:
  assumes "(0::int) < i" "i \<le> (2147483647::int)"
    "nat (sint ((of_int i::32 sword) && - of_int i)) \<le> (16777215::nat)"
    "(65535::nat) < nat (sint ((of_int i::32 sword) && - of_int i))"
  shows "sint (table.[unat ((of_int (sint ((of_int i::32 sword) && - of_int i))::32 word) >> (16::nat))]) + (16::int)
         = int (the (ls_bit (of_int i::32 word)))"
proof -
    let ?ls = "the (ls_bit ((of_int i)::32 sword))"
    from assms(1-2) have "of_int i \<noteq> (0::32 sword)"
      by (auto simp:word_of_int word_is_not_zeroI)
    from assms(1-2) have "?ls < 31"
      by (auto intro: ls_bit_less_power)
    hence "?ls < LENGTH (32 signed)"
      by simp
    from \<open>?ls < 31\<close> have "2 ^ ?ls < (2::int) ^ 31"
      by (metis numeral_One numeral_less_iff power_strict_increasing_iff semiring_norm(76))
    have "65536 = (2::nat) ^ 16"
      by eval
    from assms(4) have "?ls \<ge> 16"
      unfolding word_and_complement[OF \<open>_ \<noteq> 0\<close>]
      unfolding word_sint_msb_eq power_msb
      using \<open>?ls < 31\<close>
      apply auto
      unfolding unat_def[symmetric]
      apply auto
      by (rule p_ge_16)
    from assms(3) have " (2::nat) ^ (?ls - (16::nat)) \<le> (255::nat)"
      unfolding word_and_complement[OF \<open>_ \<noteq> 0\<close>]
      unfolding word_sint_msb_eq power_msb
      using \<open>?ls < 31\<close>
      apply auto
      unfolding unat_def[symmetric]
      by (subst power_diff[OF _ \<open>?ls \<ge> 16\<close>], auto)
    show ?thesis
      unfolding word_and_complement[OF \<open>of_int i \<noteq> _\<close>]
      apply (subst (2) word_sint_msb_eq)
      unfolding power_msb
      using \<open>the _ < 31\<close>
      apply simp
      apply (subst word_arith_power_alt)
      apply (subst word_ubin.eq_norm)
      unfolding bintrunc_mod2p
      apply simp
      apply (subst mod_le_simp)
      apply simp
      using \<open>2 ^ ?ls < _\<close>
      apply simp
      apply simp
      unfolding shiftr_div_2n'
      apply simp
      unfolding \<open>65536 = _\<close>
      thm power_diff
      apply (subst power_diff[symmetric])
      using \<open>?ls \<ge> 16\<close> apply auto
      unfolding table_2_power[OF \<open>_ \<le> 255\<close>]
      apply(auto simp:sint_word_ariths)
      unfolding word_of_nat
      unfolding word_sbin.eq_norm
      using \<open>?ls \<ge> 16\<close> \<open>?ls < 31\<close>
      apply (auto simp:sbintrunc_mod2p)
      using ls_bit_signed by metis
  qed

lemma ls_bit_correct_24:
  assumes "(0::int) < i" "i \<le> (2147483647::int)"
          "(16777215::nat) < nat (sint ((of_int i::32 sword) && - of_int i))"
  shows "sint (table.[unat ((of_int (sint ((of_int i::32 sword) && - of_int i))::32 word) >> (24::nat))]) + (24::int)
         = int (the (ls_bit (of_int i::32 word)))"
proof -
let ?ls = "the (ls_bit ((of_int i)::32 sword))"
    from assms(1-2) have "of_int i \<noteq> (0::32 sword)"
      by (auto simp:word_of_int word_is_not_zeroI)
    from assms(1-2) have "?ls < 31"
      by (auto intro: ls_bit_less_power)
    hence "?ls < LENGTH (32 signed)"
      by simp
    from \<open>?ls < 31\<close> have "2 ^ ?ls < (2::int) ^ 31"
      by (metis numeral_One numeral_less_iff power_strict_increasing_iff semiring_norm(76))
    have "16777216 = (2::nat) ^ 24"
      by eval
    from assms(3) have "?ls \<ge> 24"
      unfolding word_and_complement[OF \<open>_ \<noteq> 0\<close>]
      unfolding word_sint_msb_eq power_msb
      using \<open>?ls < 31\<close>
      apply auto
      unfolding unat_def[symmetric]
      apply auto
      by (rule p_ge_24)
    have "sint ((of_int i::32 sword) && - of_int i) \<ge> 0"
      unfolding word_and_complement[OF \<open>_ \<noteq> 0\<close>]
      unfolding word_sint_msb_eq power_msb
      using \<open>?ls < 31\<close>
      by auto
    hence "nat (sint ((of_int i::32 sword) && - of_int i)) \<le> 2 ^ 31 - 1"  (* an implicit assumption *)
      using INT_MIN_MAX_lemmas(10)[of "(of_int i::32 sword) && - of_int i"]
      unfolding INT_MAX_def
      by auto
    hence " (2::nat) ^ (?ls - (24::nat)) \<le> (255::nat)"
      unfolding word_and_complement[OF \<open>_ \<noteq> 0\<close>]
      unfolding word_sint_msb_eq power_msb
      using \<open>?ls < 31\<close>
      apply auto
      unfolding unat_def[symmetric]
      by (subst power_diff[OF _ \<open>?ls \<ge> 24\<close>], auto)
      show ?thesis
      unfolding word_and_complement[OF \<open>of_int i \<noteq> _\<close>]
      apply (subst (2) word_sint_msb_eq)
      unfolding power_msb
      using \<open>the _ < 31\<close>
      apply simp
      apply (subst word_arith_power_alt)
      apply (subst word_ubin.eq_norm)
      unfolding bintrunc_mod2p
      apply simp
      apply (subst mod_le_simp)
      apply simp
      using \<open>2 ^ ?ls < _\<close>
      apply simp
      apply simp
      unfolding shiftr_div_2n'
      apply simp
      unfolding \<open>16777216 = _\<close>
      apply (subst power_diff[symmetric])
      using \<open>?ls \<ge> 24\<close> apply auto
      unfolding table_2_power[OF \<open>_ \<le> 255\<close>]
      apply(auto simp:sint_word_ariths)
      unfolding word_of_nat
      unfolding word_sbin.eq_norm
      using \<open>?ls \<ge> 24\<close> \<open>?ls < 31\<close>
      apply (auto simp:sbintrunc_mod2p)
      using ls_bit_signed by metis
  qed
end