theory Palm_Tree
  imports
    "../Adaptors/Walk_Adaptor"
    "../Undirected_Graph/Connectivity"
    Tbd
begin

context tree
begin

definition tree_arc :: "('a, 'b) Directed_Multigraph.edge \<Rightarrow> bool" where
  "tree_arc e \<equiv> T (head e) = Some (fst e, tail e)"

lemma tree_arc_iff_edge:
  shows "tree_arc e \<longleftrightarrow> e \<in> (edges_from_map T)"
  by (auto simp add: tree_arc_def Directed_Multigraph.head_def Directed_Multigraph.tail_def Directed_Multigraph.endpoints_def edges_from_map_def)

definition tree_arc' :: "'b \<Rightarrow> 'b \<Rightarrow> bool" (infix "\<rightarrow>" 40) where
  "tree_arc' u v \<equiv> \<exists>\<epsilon>. tree_arc (\<epsilon>, u, v)"

lemma tree_arc'I:
  assumes "tree_arc e"
  shows "tail e \<rightarrow> head e"
proof -
  have "tree_arc (fst e, tail e, head e)"
    using assms
    by (simp add: head_def tail_def Directed_Multigraph.endpoints_def)
  thus ?thesis
    by (auto simp add: tree_arc'_def)
qed

lemma tree_arc'I_2:
  assumes "T v = Some (\<epsilon>, u)"
  shows "u \<rightarrow> v"
  using assms
  by (simp add: tree_arc'_def tree_arc_def head_def tail_def Directed_Multigraph.endpoints_def)

lemma tree_arc'E:
  assumes "u \<rightarrow> v"
  obtains \<epsilon> where
    "tree_arc (\<epsilon>, u, v)"
  using assms
  by (auto simp add: tree_arc'_def)

lemma tree_arc'_iff_mem_endpoints:
  shows "u \<rightarrow> v \<longleftrightarrow> (u, v) \<in> Directed_Multigraph.endpoints ` (edges_from_map T)"
  by (simp add: tree_arc'_def tree_arc_iff_edge Directed_Multigraph.mem_endpoints_iff)

lemma
  assumes "u \<rightarrow> v"
  shows
    tail_tree_arc'_mem_V: "u \<in> Directed_Multigraph.V (edges_from_map T)" and
    head_tree_arc'_mem_V: "v \<in> Directed_Multigraph.V (edges_from_map T)"
  using assms
  by (auto simp add: tree_arc'_iff_mem_endpoints intro: head_mem_V_3 tail_mem_V_3)

lemma no_loop:
  assumes "u \<rightarrow> v"
  shows "v \<noteq> u"
proof (standard, goal_cases)
  case 1
  obtain e where
    "e \<in> edges_from_map T"
    "Directed_Multigraph.endpoints e = (u, v)"
    using assms
    by (auto simp add: tree_arc'_iff_mem_endpoints)
  hence "walk (edges_from_map T) [e] u v"
    by (simp add: walk_singleton_iff)
  thus ?case
    using 1
    by (blast dest: unique_walk_3)
qed

(* TODO: We may have to require that both u and v are vertices. *)
definition tree_path :: "'b \<Rightarrow> 'b \<Rightarrow> bool" (infix "\<rightarrow>\<^sup>*" 40) where
  "tree_path u v \<equiv> (u, v) \<in> {(u, v). u \<rightarrow> v}\<^sup>*"

lemma tree_path_if_tree_arc':
  assumes "u \<rightarrow> v"
  shows "u \<rightarrow>\<^sup>* v"
  using assms
  by (auto simp add: tree_path_def)

lemma tree_path_refl:
  shows "u \<rightarrow>\<^sup>* u"
  by (simp add: tree_path_def)

lemma tree_path_trans:
  assumes "u \<rightarrow>\<^sup>* v"
  assumes "v \<rightarrow>\<^sup>* w"
  shows "u \<rightarrow>\<^sup>* w"
  using assms
  by (simp add: tree_path_def)

lemma tree_path_imp_reachable:
  assumes "u \<rightarrow>\<^sup>* v"
  assumes "u \<in> Directed_Multigraph.V (edges_from_map T)"
  shows "reachable (edges_from_map T) u v"
  using assms
  unfolding tree_path_def reachable_def
proof (induct rule: rtrancl.induct)
  case (rtrancl_refl v)
  thus ?case
    by blast
next
  case (rtrancl_into_rtrancl u v w)
  show ?case
  proof (rule rtrancl_on_into_rtrancl_on[where ?b = v], goal_cases)
    case 1
    show ?case
      using rtrancl_into_rtrancl.prems
      by (intro rtrancl_into_rtrancl.hyps(2))
  next
    case 2
    show ?case
      using rtrancl_into_rtrancl.hyps(3)
      by (simp add: tree_arc'_iff_mem_endpoints)
  next
    case 3
    show ?case
      using rtrancl_into_rtrancl.hyps(3)
      by (auto simp add: tree_arc'_iff_mem_endpoints intro: head_mem_V_3)
  qed
qed

lemma tree_path_if_reachable:
  assumes "reachable (edges_from_map T) u v"
  shows "u \<rightarrow>\<^sup>* v"
  using assms
  unfolding reachable_def tree_path_def
proof (induct rule: rtrancl_on.induct)
  case (rtrancl_on_refl v)
  thus ?case
    by simp
next
  case (rtrancl_on_into_rtrancl_on u v w)
  thus ?case
    by (simp add: tree_arc'_iff_mem_endpoints)
qed

lemma tree_path_imp_walk:
  assumes "u \<rightarrow>\<^sup>* v"
  assumes "u \<in> Directed_Multigraph.V (edges_from_map T)"
  obtains p where
    "walk (edges_from_map T) p u v"
  using assms
  by (blast dest: tree_path_imp_reachable elim: reachableE)

lemma tree_path_if_walk:
  assumes "walk (edges_from_map T) p u v"
  shows "u \<rightarrow>\<^sup>* v"
  using assms
  by (intro reachableI tree_path_if_reachable)

definition D :: "'b \<Rightarrow> 'b set" where
  "D u \<equiv> {v. u \<rightarrow>\<^sup>* v}"

lemma mem_D_iff_tree_path:
  shows "v \<in> D u \<longleftrightarrow> u \<rightarrow>\<^sup>* v"
  by (simp add: D_def)

(* TODO: Rename. *)
lemma D_refl:
  shows "v \<in> D v"
  using tree_path_refl
  by (simp add: mem_D_iff_tree_path)

lemma D_subsetI:
  assumes "u \<rightarrow>\<^sup>* v"
  shows "D v \<subseteq> D u"
  using assms
  by (auto simp add: mem_D_iff_tree_path dest: tree_path_trans)

definition ND :: "'b \<Rightarrow> nat" where
  "ND v \<equiv> card (D v)"

definition non_empty_tree_path :: "'b \<Rightarrow> 'b \<Rightarrow> bool" (infix "\<rightarrow>\<^sup>+" 40) where
  "non_empty_tree_path u v \<equiv> (u, v) \<in> {(u, v). u \<rightarrow> v}\<^sup>+"

lemma non_empty_tree_pathE:
  assumes "u \<rightarrow>\<^sup>+ w"
  obtains v where
    "u \<rightarrow> v"
    "v \<rightarrow>\<^sup>* w"
  using assms
  unfolding non_empty_tree_path_def
proof (induct rule: trancl.induct)
  case r_into_trancl
  thus ?case
    using tree_path_refl
    by fast
next
  case trancl_into_trancl
  then show ?case
    by (auto simp add: tree_path_def intro: rtrancl_into_rtrancl)
qed

lemma non_empty_tree_pathE_2:
  assumes "u \<rightarrow>\<^sup>+ w"
  obtains v where
    "u \<rightarrow>\<^sup>*  v"
    "v \<rightarrow> w"
  using assms
  unfolding non_empty_tree_path_def
proof (induct rule: trancl.induct)
  case r_into_trancl
  thus ?case
    using tree_path_refl
    by fast
next
  case trancl_into_trancl
  then show ?case
    by (auto simp add: tree_path_def intro: rtrancl_into_rtrancl)
qed

lemma non_empty_tree_pathI:
  assumes "u \<rightarrow>\<^sup>* v"
  assumes "v \<rightarrow> w"
  shows "u \<rightarrow>\<^sup>+ w"
  using assms
  by (auto simp add: tree_path_def non_empty_tree_path_def intro: rtrancl_into_trancl1)

lemma non_empty_tree_pathI_2:
  assumes "u \<rightarrow> v"
  assumes "v \<rightarrow>\<^sup>* w"
  shows "u \<rightarrow>\<^sup>+ w"
  using assms
  by (auto simp add: tree_path_def non_empty_tree_path_def intro: rtrancl_into_trancl2)

lemma non_empty_tree_path_if_tree_arc':
  assumes "u \<rightarrow> v"
  shows "u \<rightarrow>\<^sup>+ v"
  using assms
  by (auto simp add: non_empty_tree_path_def)

lemma
  assumes "u \<rightarrow>\<^sup>+ v"
  shows
    hd_non_empty_tree_path_mem_V: "u \<in> Directed_Multigraph.V (edges_from_map T)" and
    last_non_empty_tree_path_mem_V: "v \<in> Directed_Multigraph.V (edges_from_map T)"
  using assms
  unfolding non_empty_tree_path_def
  by (induct rule: trancl.induct) (auto dest: tail_tree_arc'_mem_V head_tree_arc'_mem_V)

lemma tree_path_non_empty_tree_path_cong:
  shows "u \<rightarrow>\<^sup>* v \<longleftrightarrow> u = v \<or> u \<rightarrow>\<^sup>+ v"
  using rtrancl_eq_or_trancl
  unfolding tree_path_def non_empty_tree_path_def
  by metis

lemma non_empty_tree_path_imp_tree_path:
  assumes "u \<rightarrow>\<^sup>+ v"
  shows "u \<rightarrow>\<^sup>* v"
  using assms
  by (simp add: tree_path_non_empty_tree_path_cong)

lemma non_empty_tree_path_imp_walk:
  assumes "u \<rightarrow>\<^sup>+ v"
  obtains p where
    "walk (edges_from_map T) p u v"
  using assms
  by (blast dest: non_empty_tree_path_imp_tree_path hd_non_empty_tree_path_mem_V elim: tree_path_imp_walk)

lemma non_empty_tree_path_imp_neq:
  assumes "u \<rightarrow>\<^sup>+ w"
  shows "w \<noteq> u"
proof (standard, goal_cases)
  case 1
  obtain v where
    v: "u \<rightarrow> v"
    "v \<rightarrow>\<^sup>* w"
    using assms
    by (elim non_empty_tree_pathE)
  then obtain p1 p2 where
    p1: "walk (edges_from_map T) p1 u v" and
    "walk (edges_from_map T) p2 v w"
    by (blast elim: tree_path_imp_walk dest: tree_path_if_tree_arc' tail_tree_arc'_mem_V head_tree_arc'_mem_V)
  hence "p1 = []"
    by (auto simp add: 1 dest: hd_vertex_mem_V walk_Nil unique_walk_3)
  hence "v = u"
    using p1
    by (simp add: walk_Nil_iff)
  thus ?case
    using v(1)
    by (auto dest: no_loop)
qed

lemma no_closed_tree_path:
  assumes "u \<rightarrow>\<^sup>+ v"
  shows "\<not> v \<rightarrow>\<^sup>* u"
proof (standard, goal_cases)
  obtain p1 where
    p1: "walk (edges_from_map T) p1 u v"
    using assms
    by (elim non_empty_tree_path_imp_walk)
  case 1
  hence "v \<rightarrow>\<^sup>+ u"
    using assms
    by (auto simp add: tree_path_non_empty_tree_path_cong)
  then obtain p2 where
    "walk (edges_from_map T) p2 v u"
    using assms
    by (elim non_empty_tree_path_imp_walk)
  hence "walk (edges_from_map T) (p1 @ p2) u u"
    using p1
    by (simp add: walk_append_iff last_vertex_eq)
  hence "rev_follow u = rev_follow u @ p1 @ p2"
    by (simp add: unique_walk_2)
  hence "v = u"
    using p1
    by (simp add: walk_Nil_iff)
  thus ?case
    using assms
    by (blast dest: non_empty_tree_path_imp_neq)
qed

lemma no_closed_tree_path_2:
  assumes "u \<rightarrow>\<^sup>* v"
  assumes "u \<noteq> v"
  shows "\<not> v \<rightarrow>\<^sup>* u"
  using assms
  by (auto simp add: tree_path_non_empty_tree_path_cong dest: no_closed_tree_path)

lemma no_closed_tree_path_3:
  assumes "u \<rightarrow> v"
  shows "\<not> v \<rightarrow>\<^sup>* u"
  using assms
  by (blast dest: non_empty_tree_path_if_tree_arc' no_closed_tree_path)

lemma unique_tree_path:
  assumes "u \<rightarrow>\<^sup>+ x"
  assumes "v \<rightarrow>\<^sup>+ x"
  shows "u \<rightarrow>\<^sup>* v \<or> v \<rightarrow>\<^sup>* u"
proof -
  obtain p1 p2 where
    p1: "walk (edges_from_map T) p1 u x" and
    p2: "walk (edges_from_map T) p2 v x"
    using assms
    by (elim non_empty_tree_path_imp_walk)
  hence cong: "rev_follow v @ p2 = rev_follow u @ p1"
    by (simp add: unique_walk_2)
  let ?l1 = "length (rev_follow u)"
  let ?p3 = "drop ?l1 (rev_follow v)"
  let ?l2 = "length (rev_follow v)"
  let ?p4 = "drop ?l2 (rev_follow u)"
  show ?thesis
  proof (cases "?l2 \<le> ?l1")
    case True
    hence "p2 = ?p4 @ p1"
      using cong
      by (simp add: append_eq_append_conv_if)
    hence "walk (edges_from_map T) ?p4 v u"
      using p1 p2
      by (cases p1) (auto simp add: walk_Nil_iff walk_Cons_iff walk_append_iff)
    thus ?thesis
      by (blast dest: tree_path_if_walk)
  next
    case False
    hence "p1 = ?p3 @ p2"
      using cong
      by (simp add: append_eq_append_conv_if)
    hence "walk (edges_from_map T) ?p3 u v"
      using p1 p2
      by (cases p2) (auto simp add: walk_Nil_iff walk_Cons_iff walk_append_iff)
    thus ?thesis
      by (blast dest: tree_path_if_walk)
  qed
qed

lemma unique_tree_path_2:
  assumes "u \<rightarrow>\<^sup>* x"
  assumes "v \<rightarrow>\<^sup>* x"
  shows "u \<rightarrow>\<^sup>* v \<or> v \<rightarrow>\<^sup>* u"
proof (rule ccontr, goal_cases)
  case 1
  hence
    "u \<rightarrow>\<^sup>+ x"
    "v \<rightarrow>\<^sup>+ x"
    using assms
    by (auto simp add: tree_path_non_empty_tree_path_cong)
  thus ?case
    using 1
    by (fast dest: unique_tree_path)
qed

lemma unique_tree_path_3:
  assumes "u \<rightarrow> v"
  assumes "x \<rightarrow>\<^sup>* v"
  shows "x \<rightarrow>\<^sup>* u \<or> x = v"
proof (rule ccontr, goal_cases)
  case 1
  hence "x \<rightarrow>\<^sup>+ v"
    using assms(2)
    by (simp add: tree_path_non_empty_tree_path_cong)
  then obtain e p2 where
    e: "walk (edges_from_map T) [e] u v" and
    p2: "walk (edges_from_map T) p2 x v"
    using assms
    by
      (auto
        simp add: tree_arc'_iff_mem_endpoints walk_singleton_iff
        elim: non_empty_tree_path_imp_walk)
  hence cong: "rev_follow x @ p2 = rev_follow u @ [e]"
    by (simp add: unique_walk_2)
  let ?l1 = "length (rev_follow u)"
  let ?p3 = "drop ?l1 (rev_follow x)"
  let ?l2 = "length (rev_follow x)"
  let ?p4 = "drop ?l2 (rev_follow u)"
  show ?case
  proof (cases "?l2 \<le> ?l1")
    case True
    hence "p2 = ?p4 @ [e]"
      using cong
      by (simp add: append_eq_append_conv_if)
    hence "walk (edges_from_map T) ?p4 x u"
      using e p2
      by (simp add: walk_Cons_iff walk_snoc_iff)
    thus ?thesis
      using 1
      by (blast dest: tree_path_if_walk)
  next
    case False
    show ?thesis
    proof (cases p2)
      case Nil
      thus ?thesis
        using p2 1
        by (simp add: walk_Nil_iff)
    next
      case (Cons)
      thus ?thesis
        using cong False
        by (simp add: append_eq_append_conv_if append_eq_Cons_conv)
    qed
  qed
qed

lemma unique_tree_path_4:
  assumes "u \<rightarrow> x"
  assumes "v \<rightarrow> x"
  shows "v = u"
proof -
  have
    "v \<rightarrow>\<^sup>* u"
    "u \<rightarrow>\<^sup>* v"
    using assms
    by (blast dest: tree_path_if_tree_arc' unique_tree_path_3 no_loop)+
  thus ?thesis
    by (blast dest: no_closed_tree_path_2)
qed

lemma disjoint_siblings:
  assumes "v \<rightarrow> x"
  assumes "v \<rightarrow> y"
  assumes "y \<noteq> x"
  shows "D x \<inter> D y = {}"
proof -
  { fix z
    assume
      assm: "x \<rightarrow>\<^sup>* z"
      "y \<rightarrow>\<^sup>* z"
    then consider
      "x \<rightarrow>\<^sup>* y" |
      "y \<rightarrow>\<^sup>* x"
      by (blast dest: unique_tree_path_2)
    hence False
      using assms
      by (blast dest: unique_tree_path_3 no_closed_tree_path_3) }
  thus ?thesis
    by (fastforce simp add: mem_D_iff_tree_path)
qed

lemma D_eq_singleton_if:
  assumes "x \<notin> snd ` ran T"
  shows "D x = {x}"
proof -
  { fix v
    assume
      assm: "v \<in> D x"
      "v \<noteq> x"
    hence "x \<rightarrow>\<^sup>+ v"
      by (simp add: mem_D_iff_tree_path tree_path_non_empty_tree_path_cong)
    then obtain u where
      "x \<rightarrow> u"
      "u \<rightarrow>\<^sup>* v"
      by (elim non_empty_tree_pathE)
    hence False
      using assms
      by
        (force
          simp add: tree_arc'_def tree_arc_def tail_def Directed_Multigraph.endpoints_def
          intro: ranI) }
  thus ?thesis
    using D_refl
    by blast
qed

lemma D_subsetI_2:
  assumes "u \<rightarrow>\<^sup>+ v"
  shows "D v \<subset> D u"
proof -
  have "u \<notin> D v"
    using assms
    by (auto simp add: mem_D_iff_tree_path dest: no_closed_tree_path)
  thus ?thesis
    using D_refl assms
    by (blast dest: non_empty_tree_path_imp_tree_path D_subsetI)
qed

lemma D_subset:
  assumes "v \<in> Directed_Multigraph.V (edges_from_map T)"
  shows "D v \<subseteq> Directed_Multigraph.V (edges_from_map T)"
  using assms
  by (auto simp add: mem_D_iff_tree_path tree_path_non_empty_tree_path_cong dest: last_non_empty_tree_path_mem_V)

(**)

(* TODO: Rename. *)
definition agublagu :: "'b \<Rightarrow> 'b \<rightharpoonup> 'a \<times> 'b" where
  "agublagu u v \<equiv> if u \<rightarrow>\<^sup>+ v then T v else None"

lemma agublagu_eq_NoneD:
  assumes "agublagu x v = None"
  shows "\<not> x \<rightarrow>\<^sup>+ v"
proof (standard, goal_cases)
  case 1
  then obtain u where
    "x \<rightarrow>\<^sup>* u"
    "u \<rightarrow> v"
    by (elim non_empty_tree_pathE_2)
  hence "T v \<noteq> None"
    by (auto simp add: tree_arc'_def tree_arc_def head_def Directed_Multigraph.endpoints_def)
  thus ?case
    using assms 1
    by (simp add: agublagu_def)
qed

lemma agublagu_eq_SomeD:
  assumes "agublagu x v = Some (\<epsilon>, u)"
  shows
    "u \<rightarrow> v"
    "x \<rightarrow>\<^sup>+ v"
  using assms
  by
    (auto
      simp add: agublagu_def tree_arc'_def tree_arc_def head_def tail_def Directed_Multigraph.endpoints_def
      split: if_splits)

lemma agublagu_eq_restrict_map:
  shows "agublagu u = T |` {v. u \<rightarrow>\<^sup>+ v}"
  by (auto simp add: agublagu_def restrict_map_def)

lemma map_le_agublagu:
  shows "agublagu u \<subseteq>\<^sub>m T"
  by (simp add: agublagu_eq_restrict_map map_le_def)

lemma edges_from_map_agublagu_subset:
  shows "edges_from_map (agublagu u) \<subseteq> edges_from_map T"
  using map_le_agublagu
  by (intro edges_from_map_subset_if_map_le)

lemma tree_agublagu:
  shows "tree (agublagu x) x"
proof (standard, goal_cases)
  case 1
  show ?case
    using wf
    by (auto simp add: agublagu_def intro: wf_subset)
next
  case 2
  show ?case
    by (auto simp add: agublagu_def dest: non_empty_tree_path_imp_neq)
next
  case (3 v)
  let ?T' = "agublagu x"
  have tbd: "tbd ?T'"
  proof (standard, goal_cases)
    case 1
    show ?case
      using wf
      by (auto simp add: agublagu_def intro: wf_subset)
  qed
  show ?case
    using 3
  proof (induct v rule: tbd.follow_induct[OF tbd])
    case (1 v)
    show ?case
    proof (cases rule: tbd.cases_m[OF tbd, of v])
      case 1
      thus ?thesis
        using "1.prems"
        by blast
    next
      case T'_v_eq_Some: (2 \<epsilon> u)
      show ?thesis
      proof (cases rule: tbd.cases_m[OF tbd, of u])
        case 1
        have "u = x"
        proof -
          have "x \<rightarrow>\<^sup>* u"
          proof -
            have
              "u \<rightarrow> v"
              "x \<rightarrow>\<^sup>+ v"
              using T'_v_eq_Some
              by (blast dest: agublagu_eq_SomeD)+
            thus ?thesis
              by (blast dest: non_empty_tree_path_imp_tree_path unique_tree_path_3 non_empty_tree_path_imp_neq)
          qed
          moreover have "\<not> x \<rightarrow>\<^sup>+ u"
            using 1
            by (blast dest: agublagu_eq_NoneD)
          ultimately show ?thesis
            by (simp add: tree_path_non_empty_tree_path_cong)
        qed
        thus ?thesis
          using tbd T'_v_eq_Some 1
          by (simp add: tbd.follow_simps tail_def Directed_Multigraph.endpoints_def)
      next
        case 2
        thus ?thesis
          using tbd T'_v_eq_Some
          by (auto simp add: tbd.follow_simps dest: "1.hyps")
      qed
    qed
  qed
qed

lemma agublagu_9:
  assumes "u \<in> Directed_Multigraph.V (edges_from_map (agublagu x))"
  shows "x \<rightarrow>\<^sup>* u"
proof -
  let ?T' = "agublagu x"
  obtain v where
    "(u, v) \<in> Directed_Multigraph.endpoints ` edges_from_map ?T' \<or>
     (v, u) \<in> Directed_Multigraph.endpoints ` edges_from_map ?T'"
    using assms
    by (elim Directed_Multigraph.mem_VE)
  then consider
    (u_v) "(u, v) \<in> Directed_Multigraph.endpoints ` edges_from_map ?T'" |
    (v_u) "(v, u) \<in> Directed_Multigraph.endpoints ` edges_from_map ?T'"
    by fast
  thus ?thesis
  proof (cases)
    case u_v
    then obtain \<epsilon> where
      "(\<epsilon>, u, v) \<in> edges_from_map ?T'"
      by (auto simp add: Directed_Multigraph.mem_endpoints_iff)
    hence
      "u \<rightarrow> v"
      "x \<rightarrow>\<^sup>+ v"
      by (blast dest: mem_edges_from_mapD_2 agublagu_eq_SomeD)+
    thus ?thesis
      by (blast dest: non_empty_tree_path_imp_tree_path unique_tree_path_3 non_empty_tree_path_imp_neq)
  next
    case v_u
    thus ?thesis
      by (auto simp add: Directed_Multigraph.mem_endpoints_iff dest: mem_edges_from_mapD_2 agublagu_eq_SomeD(2) non_empty_tree_path_imp_tree_path)
  qed
qed

lemma agublagu_10:
  assumes "v \<in> snd ` ran T"
  shows "Directed_Multigraph.V (edges_from_map (agublagu v)) = D v"
proof (standard, goal_cases)
  case 1
  show ?case
    by (auto simp add: mem_D_iff_tree_path intro: agublagu_9)
next
  case 2
  let ?T' = "agublagu v"
  show ?case
  proof (standard, goal_cases)
    case (1 x)
    then consider
      (eq) "x = v" |
      (non_empty_tree_path) "v \<rightarrow>\<^sup>+ x"
      by (auto simp add: mem_D_iff_tree_path tree_path_non_empty_tree_path_cong)
    thus ?case
    proof (cases)
      case eq
      then obtain \<epsilon> y where
        "T y = Some (\<epsilon>, x)"
        "v \<rightarrow>\<^sup>+ y"
        using assms
        by (fastforce simp add: ran_def intro: tree_arc'I_2 non_empty_tree_path_if_tree_arc')
      thus ?thesis
        by (fastforce simp add: agublagu_def intro: mem_edges_from_mapI tail_mem_V_2)
    next
      case non_empty_tree_path
      hence "?T' x \<noteq> None"
        using agublagu_eq_NoneD
        by blast
      then obtain \<epsilon> y where
        "T x = Some (\<epsilon>, y)"
        by (auto simp add: agublagu_def split: if_splits)
      thus ?thesis
        using non_empty_tree_path
        by (fastforce simp add: agublagu_def intro: mem_edges_from_mapI head_mem_V_2)
    qed
  qed
qed

definition agublagu_3 :: "'b \<Rightarrow> 'b \<rightharpoonup> 'a \<times> 'b" where
  "agublagu_3 u v \<equiv> if u \<rightarrow>\<^sup>* v then None else T v"

lemma agublagu_3_eq_NoneD:
  assumes "agublagu_3 x v = None"
  shows "x \<rightarrow>\<^sup>* v \<or> T v = None"
  using assms
  by (simp add: agublagu_3_def split: if_splits)

lemma agublagu_3_eq_SomeD:
  assumes "agublagu_3 x v = Some (\<epsilon>, u)"
  shows
    "\<not> x \<rightarrow>\<^sup>* v"
    "T v = Some (\<epsilon>, u)"
  using assms
  by (simp_all add: agublagu_3_def split: if_splits)

lemma agublagu_3_eq_restrict_map:
  shows "agublagu_3 u = T |` (- D u)"
  by (auto simp add: agublagu_3_def mem_D_iff_tree_path)

lemma map_le_agublagu_3:
  shows "agublagu_3 u \<subseteq>\<^sub>m T"
  by (simp add: agublagu_3_eq_restrict_map map_le_def)

lemma edges_from_map_agublagu_3_subset:
  shows "edges_from_map (agublagu_3 u) \<subseteq> edges_from_map T"
  using map_le_agublagu_3
  by (intro edges_from_map_subset_if_map_le)

lemma tree_agublagu_3:
  shows "tree (agublagu_3 x) r"
proof (standard, goal_cases)
  case 1
  show ?case
    using wf
    by (auto simp add: agublagu_3_def intro: wf_subset)
next
  case 2
  show ?case
    using T_r_eq_None
    by (simp add: agublagu_3_def)
next
  let ?T' = "agublagu_3 x"
  case (3 v)
  have tbd: "tbd ?T'"
  proof (standard, goal_cases)
    case 1
    show ?case
      using wf
      by (auto simp add: agublagu_3_def intro: wf_subset)
  qed
  show ?case
    using 3
  proof (induct v rule: tbd.follow_induct[OF tbd])
    case (1 v)
    show ?case
    proof (cases rule: tbd.cases_m[OF tbd, of v])
      case 1
      thus ?thesis
        using "1.prems"
        by simp
    next
      case T'_v_eq_Some: (2 \<epsilon> u)
      show ?thesis
      proof (cases rule: tbd.cases_m[OF tbd, of u])
        case T'_u_eq_None: 1
        then consider
          "x \<rightarrow>\<^sup>* u" |
          "T u = None"
          by (force dest: agublagu_3_eq_NoneD)
        thus ?thesis
        proof (cases)
          case 1
          thus ?thesis
            using T'_v_eq_Some
            by (blast dest: agublagu_3_eq_SomeD tree_arc'I_2 tree_path_if_tree_arc' tree_path_trans)
        next
          case 2
          hence "u = r"
            using tail_last_follow_eq_r T'_v_eq_Some
            by
              (fastforce
                simp add: follow_simps tail_def Directed_Multigraph.endpoints_def
                dest: agublagu_3_eq_SomeD(2))
          thus ?thesis
            using tbd T'_v_eq_Some T'_u_eq_None
            by (simp add: tbd.follow_simps tail_def Directed_Multigraph.endpoints_def)
        qed
      next
        case 2
        thus ?thesis
          using tbd T'_v_eq_Some
          by (auto simp add: tbd.follow_simps dest: "1.hyps")
      qed
    qed
  qed
qed

lemma agublagu_3_9:
  assumes "u \<in> Directed_Multigraph.V (edges_from_map (agublagu_3 x))"
  shows "\<not> x \<rightarrow>\<^sup>* u"
proof -
  let ?T' = "agublagu_3 x"
  obtain v where
    "(u, v) \<in> Directed_Multigraph.endpoints ` edges_from_map ?T' \<or>
     (v, u) \<in> Directed_Multigraph.endpoints ` edges_from_map ?T'"
    using assms
    by (elim Directed_Multigraph.mem_VE)
  then consider
    (u_v) "(u, v) \<in> Directed_Multigraph.endpoints ` edges_from_map ?T'" |
    (v_u) "(v, u) \<in> Directed_Multigraph.endpoints ` edges_from_map ?T'"
    by fast
  thus ?thesis
  proof (cases)
    case u_v
    show ?thesis
    proof (standard, goal_cases)
      case 1
      obtain \<epsilon> where
        "(\<epsilon>, u, v) \<in> edges_from_map ?T'"
        using u_v
        by (auto simp add: Directed_Multigraph.mem_endpoints_iff)
      thus ?case
        using 1
        by (fast dest: mem_edges_from_mapD_2 agublagu_3_eq_SomeD tree_arc'I_2 tree_path_if_tree_arc' tree_path_trans)
    qed
  next
    case v_u
    thus ?thesis
      by (auto simp add: Directed_Multigraph.mem_endpoints_iff dest: mem_edges_from_mapD_2 agublagu_3_eq_SomeD(1))
  qed
qed

(* QQQ *)
\<comment> \<open>
This lemma is false! If v is the child of r, then agublagu_3 v is the empty map but D r - D v = {r}.
\<close>
lemma agublagu_3_10:
  assumes "r \<in> snd ` ran T"
  shows "Directed_Multigraph.V (edges_from_map (agublagu_3 v)) = D r - D v"
proof (standard, goal_cases)
  let ?T' = "agublagu_3 v"
  case 1
  show ?case
  proof (standard, goal_cases)
    case (1 x)
    have "r \<rightarrow>\<^sup>* x"
    proof -
      obtain y where
        "(x, y) \<in> Directed_Multigraph.endpoints ` edges_from_map ?T' \<or>
         (y, x) \<in> Directed_Multigraph.endpoints ` edges_from_map ?T'"
        using 1
        by (elim Directed_Multigraph.mem_VE)
      then consider
        (x_y) "(x, y) \<in> Directed_Multigraph.endpoints ` edges_from_map ?T'" |
        (y_x) "(y, x) \<in> Directed_Multigraph.endpoints ` edges_from_map ?T'"
        by fast
      thus ?thesis
      proof (cases)
        case x_y
        then obtain \<epsilon> where
          T_y_eq_Some: "T y = Some (\<epsilon>, x)"
          by
            (auto
              simp add: Directed_Multigraph.mem_endpoints_iff
              dest: mem_edges_from_mapD_2 agublagu_3_eq_SomeD(2))
        hence
          "x \<rightarrow> y"
          "r \<rightarrow>\<^sup>* y"
          by (blast intro: tree_arc'I_2 walk_rev_follow tree_path_if_walk)+
        then show ?thesis
          using T_y_eq_Some T_r_eq_None
          by (fastforce dest: unique_tree_path_3)
      next
        case y_x
        then obtain \<epsilon> where
          "(\<epsilon>, y, x) \<in> edges_from_map ?T'"
          by (auto simp add: Directed_Multigraph.mem_endpoints_iff)
        thus ?thesis
          by
            (fastforce
              dest: mem_edges_from_mapD_2 agublagu_3_eq_SomeD(2)
              intro: walk_rev_follow tree_path_if_walk)
      qed
    qed
    thus ?case
      using 1
      by (auto simp add: mem_D_iff_tree_path dest: agublagu_3_9)
  qed
next
  case 2
  thm agublagu_3_eq_NoneD
  thm unique_tree_path_3
  then show ?case sorry
qed

end

locale lololol =
  tree
  where T = T +
    other
  where other = other
  for T :: "'b \<rightharpoonup> 'a \<times> 'b"
    and other :: "('a, 'b) Multigraph.edge \<Rightarrow> 'b \<Rightarrow> 'b"
begin

lemma connected':
  shows "connected' (undirect ` edges_from_map T) (Directed_Multigraph.V (edges_from_map T))"
  sorry

end

(* QUESTION: Define via the graph induced by T? *)
locale tree_of =
  tree
  where T = T +
    Directed_Multigraph.finite_multigraph
  where G = P
  for T :: "'b \<rightharpoonup> 'a \<times> 'b"
    and P :: "('a, 'b) Directed_Multigraph.multigraph" +
  assumes r_mem_V: "r \<in> Directed_Multigraph.V P"
  assumes tree_arc_imp_edge: "tree_arc e \<Longrightarrow> e \<in> P"
begin

lemma edges_from_map_subset:
  shows "edges_from_map T \<subseteq> P"
  by (auto simp add: tree_arc_iff_edge intro: tree_arc_imp_edge)

lemma finite_edges_from_map:
  shows "finite (edges_from_map T)"
proof -
  have "edges_from_map T \<subseteq> P"
    by (auto simp add: tree_arc_iff_edge intro: tree_arc_imp_edge)
  thus ?thesis
    using finite_edges
    by (rule finite_subset)
qed

lemma tree_arc'E_2:
  assumes "u \<rightarrow> v"
  obtains \<epsilon> where
    "(\<epsilon>, u, v) \<in> P"
  using assms
  by (auto dest: tree_arc_imp_edge elim: tree_arc'E)

lemma
  assumes "u \<rightarrow> v"
  shows
    tail_tree_arc'_mem_V: "u \<in> Directed_Multigraph.V P" and
    head_tree_arc'_mem_V: "v \<in> Directed_Multigraph.V P"
  using assms
  by (auto dest: tree_arc_imp_edge tail_mem_V_2 head_mem_V_2 elim: tree_arc'E)

lemma
  assumes "u \<rightarrow>\<^sup>+ v"
  shows
    hd_non_empty_tree_path_mem_V: "u \<in> Directed_Multigraph.V P" and
    last_non_empty_tree_path_mem_V: "v \<in> Directed_Multigraph.V P"
  using assms
  unfolding non_empty_tree_path_def
  by (induct rule: trancl.induct) (auto dest: tail_tree_arc'_mem_V head_tree_arc'_mem_V)

lemma V_edges_from_map_subset:
  shows "Directed_Multigraph.V (edges_from_map T) \<subseteq> Directed_Multigraph.V P"
proof (standard)
  fix u
  assume "u \<in> Directed_Multigraph.V (edges_from_map T)"
  then obtain v where
    "(u, v) \<in> Directed_Multigraph.endpoints ` (edges_from_map T) \<or>
     (v, u) \<in> Directed_Multigraph.endpoints ` (edges_from_map T)"
    by (elim Directed_Multigraph.mem_VE)
  thus "u \<in> Directed_Multigraph.V P"
    by
      (auto
        simp add: tree_arc'_iff_mem_endpoints[symmetric]
        dest: head_tree_arc'_mem_V tail_tree_arc'_mem_V)
qed

lemma finite_D:
  shows "finite (D u)"
proof (cases "u \<in> Directed_Multigraph.V (edges_from_map T)")
  case True
  thus ?thesis
    using finite_vertices
    by (metis D_subset V_edges_from_map_subset finite_subset)
next
  case False
  have "D u = {u}"
  proof (standard, goal_cases)
    case 1
    { fix v
      assume
        assm: "v \<in> D u"
        "v \<noteq> u"
      hence "u \<rightarrow>\<^sup>+ v"
        by (simp add: mem_D_iff_tree_path tree_path_non_empty_tree_path_cong)
      hence False
        using tree_axioms False
        by (fast dest: tree.hd_non_empty_tree_path_mem_V) }
    thus ?case
      by blast
  next
    case 2
    show ?case
      using D_refl
      by auto
  qed
  thus ?thesis
    by simp
qed

lemma ND_greater_0:
  shows "0 < ND v"
  using D_refl finite_D
  by (auto simp add: ND_def card_gt_0_iff)

definition frond :: "('a, 'b) Directed_Multigraph.edge \<Rightarrow> bool" where
  "frond e \<equiv> e \<in> P \<and> \<not> tree_arc e"

lemma frond_iff_not_tree_arc:
  assumes "e \<in> P"
  shows "frond e \<longleftrightarrow> \<not> tree_arc e"
  using assms
  by (simp add: frond_def)

definition frond' :: "'b \<Rightarrow> 'b \<Rightarrow> bool" (infix "\<hookrightarrow>" 40) where
  "frond' u v \<equiv> \<exists>\<epsilon>. frond (\<epsilon>, u, v)"

lemma frond'E:
  assumes "u \<hookrightarrow> v"
  obtains \<epsilon> where
    "(\<epsilon>, u, v) \<in> P"
  using assms
  by (auto simp add: frond'_def frond_def)

lemma frond'I:
  assumes "frond e"
  shows "tail e \<hookrightarrow> head e"
proof -
  have "frond (fst e, tail e, head e)"
    using assms
    by (simp add: Directed_Multigraph.head_def Directed_Multigraph.tail_def Directed_Multigraph.endpoints_def)
  thus ?thesis
    by (auto simp add: frond'_def)
qed

lemma
  assumes "u \<hookrightarrow> v"
  shows
    tail_frond'_mem_V: "u \<in> Directed_Multigraph.V P" and
    head_frond'_mem_V: "v \<in> Directed_Multigraph.V P"
  using assms
  by (auto dest: tail_mem_V_2 head_mem_V_2 elim: frond'E)

lemma edge_imp:
  assumes "(\<epsilon>, u, v) \<in> P"
  shows "u \<rightarrow> v \<or> u \<hookrightarrow> v"
  using assms
  by (fastforce simp add: tree_arc'_def frond'_def dest: frond_iff_not_tree_arc)

lemma edge_iff:
  shows "(\<exists>\<epsilon>. (\<epsilon>, u, v) \<in> P) \<longleftrightarrow> u \<rightarrow> v \<or> u \<hookrightarrow> v"
  by (auto dest: edge_imp elim: tree_arc'E_2 frond'E)

lemma edge_iff_2:
  shows "(u, v) \<in> Directed_Multigraph.endpoints ` P \<longleftrightarrow> u \<rightarrow> v \<or> u \<hookrightarrow> v"
  unfolding Directed_Multigraph.mem_endpoints_iff
  using edge_iff
  .

definition tree_path_snoc_frond' :: "'b \<Rightarrow> 'b \<Rightarrow> bool" (infix "\<rightarrow>\<^sup>*\<hookrightarrow>" 40) where
  "tree_path_snoc_frond' u v \<equiv> \<exists>x. u \<rightarrow>\<^sup>* x \<and> x \<hookrightarrow> v"

lemma tree_path_snoc_frond'E:
  assumes "u \<rightarrow>\<^sup>*\<hookrightarrow> w"
  obtains v where
    "u \<rightarrow>\<^sup>* v"
    "v \<hookrightarrow> w"
  using assms
  by (auto simp add: tree_path_snoc_frond'_def)

lemma tree_path_snoc_frond'I:
  assumes "u \<rightarrow>\<^sup>* v"
  assumes "v \<hookrightarrow> w"
  shows "u \<rightarrow>\<^sup>*\<hookrightarrow> w"
  using assms
  by (auto simp add: tree_path_snoc_frond'_def)

lemma tree_path_snoc_frond'I_2:
  assumes "u \<rightarrow>\<^sup>* v"
  assumes "v \<rightarrow>\<^sup>*\<hookrightarrow> w"
  shows "u \<rightarrow>\<^sup>*\<hookrightarrow> w"
  using assms
  by (auto simp add: tree_path_snoc_frond'_def dest: tree_path_trans)

lemma tree_path_snoc_frond'_if_frond':
  assumes "u \<hookrightarrow> v"
  shows "u \<rightarrow>\<^sup>*\<hookrightarrow> v"
  using tree_path_refl assms
  by (auto simp add: tree_path_snoc_frond'_def)

lemma tree_path_snoc_frond'_10:
  assumes "u \<rightarrow>\<^sup>*\<hookrightarrow> v"
  shows "u \<hookrightarrow> v \<or> (\<exists>x. u \<rightarrow> x \<and> x \<rightarrow>\<^sup>*\<hookrightarrow> v)"
  using assms
  by (force simp add: tree_path_snoc_frond'_def tree_path_non_empty_tree_path_cong elim: non_empty_tree_pathE)

lemma
  assumes "u \<rightarrow>\<^sup>*\<hookrightarrow> v"
  shows
    hd_tree_path_snoc_frond'_mem_V: "u \<in> Directed_Multigraph.V P" and
    last_tree_path_snoc_frond'_mem_V: "v \<in> Directed_Multigraph.V P"
proof (goal_cases)
  case 1
  obtain x where
    "u \<rightarrow>\<^sup>* x"
    "x \<hookrightarrow> v"
    using assms
    by (elim tree_path_snoc_frond'E)
  then consider
    "u \<hookrightarrow> v" |
    "u \<rightarrow>\<^sup>+ x"
    by (auto simp add: tree_path_non_empty_tree_path_cong)
  thus ?case
  proof (cases)
    case 1
    thus ?thesis
      by (intro tail_frond'_mem_V)
  next
    case 2
    thus ?thesis
      by (intro hd_non_empty_tree_path_mem_V)
  qed
next
  case 2
  show ?case
    using assms
    by (blast dest: head_frond'_mem_V elim: tree_path_snoc_frond'E)
qed

end

definition restrict_fun :: "('a \<Rightarrow> 'b list) \<Rightarrow> 'a set \<Rightarrow> 'a \<Rightarrow> 'b list" where
  "restrict_fun f A \<equiv> (\<lambda>x. if x \<in> A then f x else [])"

lemma restrict_fun_eq_override_on:
  shows "restrict_fun f A = override_on (\<lambda>_. []) f A"
  by (simp add: restrict_fun_def override_on_def)

locale tree_of_2 =
  tree
  where T = T +
    finite_multigraph_2
  where I = I
  for T :: "'b \<rightharpoonup> 'a \<times> 'b"
    and I :: "'b \<Rightarrow> ('a \<times> 'b) list" +
  assumes r_mem_V: "r \<in> Directed_Multigraph.V (edges_from_fun I)"
  assumes T_eq_Some_imp_mem_I: "T v = Some (\<epsilon>, u) \<Longrightarrow> (\<epsilon>, v) \<in> set (I u)"
begin
sublocale tree_of r T "edges_from_fun I"
proof (standard, goal_cases)
  case 1
  show ?case
    using r_mem_V
    .
next
  case (2 e)
  let ?\<epsilon> = "fst e"
  let ?u = "tail e"
  let ?v = "head e"
  have "T ?v = Some (?\<epsilon>, ?u)"
    using 2
    by (simp add: tree_arc_def)
  hence "(?\<epsilon>, ?v) \<in> set (I ?u)"
    by (intro T_eq_Some_imp_mem_I)
  hence "(?\<epsilon>, ?u, ?v) \<in> set (incidence I ?u)"
    by (force simp add: incidence_def to_edge_def)
  hence "e \<in> set (incidence I ?u)"
    by (simp add: Directed_Multigraph.tail_def Directed_Multigraph.head_def Directed_Multigraph.endpoints_def)
  thus ?case
    by (auto simp add: edges_from_fun_def)
qed

(* TODO: Move. *)
function (domintros) flatten :: "'b \<Rightarrow> ('a \<times> 'b) list" where
  "flatten u =
   fold
    (\<lambda>p. (@) (p # (if tree_arc (fst p, u, snd p) then flatten (snd p) else [])))
    (I u)
    []"
  by auto

(* TODO: Move. *)
definition agublagu_2 :: "'b \<Rightarrow> 'b \<Rightarrow> ('a \<times> 'b) list" where
  "agublagu_2 u v \<equiv> if u \<rightarrow>\<^sup>* v then I v else []"

lemma agublagu_2_eq_restrict_fun:
  shows "agublagu_2 u = restrict_fun I (D u)"
  by (auto simp add: agublagu_2_def restrict_fun_def D_def)

lemma flatten_pinduct:
  assumes "flatten_dom u"
  assumes "\<And>u. (\<And>p. p \<in> set (I u) \<Longrightarrow> tree_arc (fst p, u, snd p) \<Longrightarrow> P (snd p)) \<Longrightarrow> P u"
  shows "P u"
  using assms
  by (rule flatten.pinduct)

end

locale spanning_tree = tree_of +
  assumes spanning: "v \<in> Directed_Multigraph.V P \<Longrightarrow> v \<in> Directed_Multigraph.V (edges_from_map T)"
begin

lemma tree_path_if_mem_V:
  assumes "u \<in> Directed_Multigraph.V P"
  shows "r \<rightarrow>\<^sup>* u"
proof -
  obtain v where
      "(u, v) \<in> Directed_Multigraph.endpoints ` (edges_from_map T) \<or>
       (v, u) \<in> Directed_Multigraph.endpoints ` (edges_from_map T)"
    using assms
    by (fastforce elim: Directed_Multigraph.mem_VE dest: spanning)
  then consider
    (u_v) "(u, v) \<in> Directed_Multigraph.endpoints ` (edges_from_map T)" |
    (v_u) "(v, u) \<in> Directed_Multigraph.endpoints ` (edges_from_map T)"
    by blast
  thus ?thesis
  proof (cases)
    case u_v
    have T_v_neq_None: "T v \<noteq> None"
      using u_v
      by (auto simp add: head_def Directed_Multigraph.endpoints_def dest: mem_edges_from_mapD)
    show ?thesis
    proof (rule ccontr, goal_cases)
      case 1
      have "u \<rightarrow> v"
        using u_v
        by (simp add: tree_arc'_iff_mem_endpoints)
      moreover have "r \<rightarrow>\<^sup>* v"
        using T_v_neq_None
        by (auto intro: walk_rev_follow tree_path_if_walk)
      ultimately have "r = v"
        using 1
        by (blast dest: unique_tree_path_3)
      thus ?case
        using T_r_eq_None T_v_neq_None
        by blast
    qed
  next
    case v_u
    hence "T u \<noteq> None"
      using v_u
      by (auto simp add: head_def Directed_Multigraph.endpoints_def dest: mem_edges_from_mapD)
    thus ?thesis
      by (auto intro: walk_rev_follow tree_path_if_walk)
  qed
qed

lemma V_eq:
  shows "Directed_Multigraph.V P = Directed_Multigraph.V (edges_from_map T)"
  using V_edges_from_map_subset
  by (blast intro: spanning)

end

locale spanning_tree_2 = tree_of_2 +
  assumes spanning: "v \<in> Directed_Multigraph.V (edges_from_fun I) \<Longrightarrow> v \<in> Directed_Multigraph.V (edges_from_map T)"
begin
sublocale spanning_tree r T "edges_from_fun I"
proof (standard, goal_cases)
  case (1 v)
  thus ?case
    by (intro spanning)
qed
end

locale palm_tree = spanning_tree +
  assumes frond'_imp_tree_path: "u \<hookrightarrow> v \<Longrightarrow> v \<rightarrow>\<^sup>* u"
begin

lemma tree_path_snoc_frond'_imp_tree_path:
  assumes "u \<rightarrow>\<^sup>*\<hookrightarrow> v"
  shows "u \<rightarrow>\<^sup>* v \<or> v \<rightarrow>\<^sup>* u"
  using assms
  by (auto dest: frond'_imp_tree_path unique_tree_path_2 elim: tree_path_snoc_frond'E)

lemma D_r_eq_V:
  shows "D r = Directed_Multigraph.V P"
proof (standard, standard, goal_cases)
  case (1 v)
  thus ?case
    using r_mem_V
    by
      (auto
        simp add: mem_D_iff_tree_path tree_path_non_empty_tree_path_cong
        dest: last_non_empty_tree_path_mem_V)
next
  case 2
  show ?case
    by (auto simp add: mem_D_iff_tree_path intro: tree_path_if_mem_V)
qed
end

locale palm_tree_2 = spanning_tree_2 +
  assumes frond'_imp_tree_path: "frond' u v \<Longrightarrow> v \<rightarrow>\<^sup>* u"
begin
sublocale palm_tree r T "edges_from_fun I"
proof (standard, goal_cases)
  case (1 u v)
  thus ?case
    by (intro frond'_imp_tree_path)
qed
end

locale palm_tree_of =
  palm_tree
  where P = P +
    Multigraph.finite_multigraph
  where G = G
  for P :: "('a, 'b) Directed_Multigraph.multigraph"
    and G :: "('a, 'b) Multigraph.multigraph" +
  assumes undirect_P_eq_G: "undirect ` P = G"
begin
sublocale lololol r T other
  ..
sublocale huehuehue P other
  ..
end

lemma (in huehuehue) is_palm_tree_of_image_undirect:
  assumes "palm_tree r T G"
  shows "palm_tree_of r T other G (undirect ` G)"
  using assms finite_multigraph_axioms
  by (auto simp add: palm_tree_of_axioms_def intro: palm_tree_of.intro)

context palm_tree_of
begin

lemma connected'_D:
  assumes "v \<in> Directed_Multigraph.V P"
  shows "connected' (undirect ` P) (D v)"
proof (cases "v \<in> snd ` ran T")
  case True
  let ?T' = "agublagu v"
  have "lololol v ?T' other"
    using tree_agublagu other_axioms
    by (intro lololol.intro)
  hence "connected' (undirect ` edges_from_map ?T') (Directed_Multigraph.V (edges_from_map ?T'))"
    by (intro lololol.connected')
  hence "connected' (undirect ` edges_from_map T) (Directed_Multigraph.V (edges_from_map ?T'))"
    using edges_from_map_agublagu_subset
    by (blast dest: image_mono connected'_supergraph)
  hence "connected' (undirect ` P) (Directed_Multigraph.V (edges_from_map ?T'))"
    using edges_from_map_subset
    by (blast dest: image_mono connected'_supergraph)
  thus ?thesis
    using True
    by (simp add: V_eq agublagu_10)
next
  case False
  hence "D v = {v}"
    by (intro D_eq_singleton_if)
  thus ?thesis
    using assms
    by (auto simp add: V_image_undirect_eq intro: connected'_singleton)
qed

lemma tree_path_agublaguI:
  assumes "x \<rightarrow>\<^sup>* u"
  assumes "u \<rightarrow>\<^sup>* v"
  shows "tree.tree_path (agublagu x) u v"
  using assms(2)
  unfolding tree_path_def
  using assms(1)
proof (induct rule: rtrancl.induct)
  case (rtrancl_refl)
  show ?case
    using tree_agublagu
    by (fast dest: tree.tree_path_refl)
next
  case (rtrancl_into_rtrancl u v w)
  let ?T' = "agublagu x"
  have tree: "tree ?T' x"
    using tree_agublagu
    .
  have "tree.tree_arc' ?T' v w"
  proof -
    obtain \<epsilon>
      where "T w = Some (\<epsilon>, v)"
      using rtrancl_into_rtrancl.hyps(3)
      by
        (auto
          simp add: tree_arc_def head_def tail_def Directed_Multigraph.endpoints_def
          elim: tree_arc'E)
    moreover have "x \<rightarrow>\<^sup>+ w"
      using rtrancl_into_rtrancl.prems rtrancl_into_rtrancl.hyps(1, 3)
      by
        (auto
          simp add: tree_path_def non_empty_tree_path_def
          intro: rtrancl_into_trancl1 rtrancl_trancl_trancl)
    ultimately have "?T' w = Some (\<epsilon>, v)"
      by (simp add: agublagu_def)
    thus ?thesis
      using tree
      by (fastforce simp add: tree.tree_arc'_def tree.tree_arc_iff_edge intro: mem_edges_from_mapI)
  qed
  thus ?case
    using tree_agublagu rtrancl_into_rtrancl.hyps(2)[OF rtrancl_into_rtrancl.prems]
    by (fast intro: tree.tree_path_if_tree_arc' tree.tree_path_trans)
qed

lemma tree_path_agublaguD:
  assumes "tree.tree_path (agublagu x) u v"
  shows "u \<rightarrow>\<^sup>* v"
  using assms
  unfolding tree.tree_path_def[OF tree_agublagu]
proof (induct rule: rtrancl.induct)
  case (rtrancl_refl)
  show ?case
    using tree_path_refl
    .
next
  case (rtrancl_into_rtrancl u v w)
  let ?T' = "agublagu x"
  have tree: "tree ?T' x"
    using tree_agublagu
    .
  have "v \<rightarrow> w"
  proof -
    obtain \<epsilon>
      where "?T' w = Some (\<epsilon>, v)"
      using tree rtrancl_into_rtrancl.hyps(3)
      by
        (auto
          simp add: tree.tree_arc_def head_def tail_def Directed_Multigraph.endpoints_def
          intro: tree.tree_arc'E)
    hence "T w = Some (\<epsilon>, v)"
      by (simp add: agublagu_def split: if_splits)
    thus ?thesis
      by (auto simp add: tree_arc'_def tree_arc_iff_edge intro: mem_edges_from_mapI)
  qed
  thus ?case
    using rtrancl_into_rtrancl.hyps(2)
    by (fast intro: tree_path_if_tree_arc' tree_path_trans)
qed

lemma D_agublagu_eq:
  assumes "x \<rightarrow>\<^sup>* u"
  shows "tree.D (agublagu x) u = D u"
proof (standard, goal_cases)
  case 1
  let ?T' = "agublagu x"
  have tree: "tree ?T' x"
    using tree_agublagu
    .
  show ?case
  proof (standard, goal_cases)
    case (1 v)
    hence "tree.tree_path ?T' u v"
      using tree
      by (simp add: tree.mem_D_iff_tree_path)
    thus ?case
      by (auto simp add: mem_D_iff_tree_path dest: tree_path_agublaguD)
  qed
next
  case 2
  let ?T' = "agublagu x"
  have tree: "tree ?T' x"
    using tree_agublagu
    .
  show ?case
  proof (standard, goal_cases)
    case (1 v)
    hence "tree.tree_path ?T' u v"
      using assms
      by (auto simp add: mem_D_iff_tree_path intro: tree_path_agublaguI)
    thus ?case
      using tree
      by (simp add: tree.mem_D_iff_tree_path)
  qed
qed

lemma connected'_Diff_D:
  assumes "u \<in> Directed_Multigraph.V P"
  assumes "u \<rightarrow>\<^sup>* v"
  shows "connected' (undirect ` P) (D u - D v)"
proof (cases "u \<in> snd ` ran T")
  case True
  let ?T1 = "agublagu u"
  let ?T2 = "tree.agublagu_3 ?T1 v"
  have u_mem_ran_T1: "u \<in> snd ` ran ?T1"
  proof -
    obtain \<epsilon> x where
      "T x = Some (\<epsilon>, u)"
      using True
      by (auto simp add: ran_def)
    hence "?T1 x = Some (\<epsilon>, u)"
      by (auto simp add: agublagu_def dest: tree_arc'I_2 non_empty_tree_path_if_tree_arc')
    thus ?thesis
      by (force intro: ranI)
  qed
  have tree_T1: "tree ?T1 u"
    using tree_agublagu
    .
  hence "lololol u ?T2 other"
    using other_axioms
    by (fast intro: tree.tree_agublagu_3 lololol.intro)
  hence "connected' (undirect ` edges_from_map ?T2) (Directed_Multigraph.V (edges_from_map ?T2))"
    by (intro lololol.connected')
  hence "connected' (undirect ` edges_from_map ?T1) (Directed_Multigraph.V (edges_from_map ?T2))"
    using tree_T1
    by (blast dest: tree.edges_from_map_agublagu_3_subset image_mono connected'_supergraph)
  hence "connected' (undirect ` edges_from_map T) (Directed_Multigraph.V (edges_from_map ?T2))"
    using edges_from_map_agublagu_subset
    by (blast dest: image_mono connected'_supergraph)
  hence "connected' (undirect ` P) (Directed_Multigraph.V (edges_from_map ?T2))"
    using edges_from_map_subset
    by (blast dest: image_mono connected'_supergraph)
  hence "connected' (undirect ` P) (tree.D ?T1 u - tree.D ?T1 v)"
    using tree_T1 u_mem_ran_T1
    by (simp add: tree.agublagu_3_10)
  thus ?thesis
    using tree_path_refl assms(2)
    by (simp add: D_agublagu_eq)
next
  case False
  hence "D u = {u}"
    by (intro D_eq_singleton_if)
  thus ?thesis
    using connected'_empty assms(2)
    by (simp add: mem_D_iff_tree_path[symmetric])
qed

lemma D_subset_connected_component:
  assumes "v \<in> Directed_Multigraph.V P"
  shows "D v \<subseteq> connected_component (undirect ` P) v"
  sorry

lemma edge_iff_3:
  shows "{u, v} \<in> Multigraph.endpoints ` G \<longleftrightarrow> u \<rightarrow> v \<or> v \<rightarrow> u \<or> u \<hookrightarrow> v \<or> v \<hookrightarrow> u"
  by (auto simp add: undirect_P_eq_G[symmetric] mem_endpoints_image_undirect_iff edge_iff_2)

lemma cases_edge [consumes 1, case_names tree_arc_1 tree_arc_2 frond_1 frond_2]:
  assumes "{u, v} \<in> Multigraph.endpoints ` G"
  assumes "u \<rightarrow> v \<Longrightarrow> Q"
  assumes "v \<rightarrow> u \<Longrightarrow> Q"
  assumes "u \<hookrightarrow> v \<Longrightarrow> Q"
  assumes "v \<hookrightarrow> u \<Longrightarrow> Q"
  shows "Q"
  using assms
  by (auto simp add: edge_iff_3)

end

locale palm_tree_of_2 =
  palm_tree_2
  where I = I +
    Multigraph.finite_multigraph
  where G = G
  for I :: "'b \<Rightarrow> ('a \<times> 'b) list"
    and G :: "('a, 'b) Multigraph.multigraph" +
  assumes undirect_edges_from_fun_eq: "undirect ` edges_from_fun I = G"
begin
sublocale palm_tree_of r T other "edges_from_fun I" G
proof (standard, goal_cases)
  case 1
  show ?case
    using undirect_edges_from_fun_eq
    .
qed
end

end


theory CNF_Formulas_Sema
imports CNF_Sema CNF_Formulas Sema
begin

lemma nnf_semantics: "\<A> \<Turnstile> nnf F \<longleftrightarrow> \<A> \<Turnstile> F"
  by(induction F rule: nnf.induct; simp)

lemma cnf_semantics: "is_nnf F \<Longrightarrow> cnf_semantics \<A> (cnf F) \<longleftrightarrow> \<A> \<Turnstile> F"
  by(induction F rule: cnf.induct; simp add: cnf_semantics_def clause_semantics_def ball_Un; metis Un_iff)
  (* surprisingly, the solvers are smarter if this one is done on mutlisets.*)

lemma cnf_form_semantics:
  fixes F :: "'a formula"
  assumes nnf: "is_nnf F"
  shows "\<A> \<Turnstile> cnf_form_of F \<longleftrightarrow> \<A> \<Turnstile> F"
proof -
  define cnf_semantics_list
    where "cnf_semantics_list \<A> S \<longleftrightarrow> (\<forall>s \<in> set S. \<exists>l \<in> set s. lit_semantics \<A> (l :: 'a literal))"
    for \<A> S
  have tcn: "cnf F = set (map set (cnf_lists F))" using nnf
    by(induction F rule: cnf.induct) (auto simp add: image_UN image_comp comp_def )
  have "\<A> \<Turnstile> F \<longleftrightarrow> cnf_semantics \<A> (cnf F)" using cnf_semantics[OF nnf] by simp
  also have "\<dots> = cnf_semantics \<A> (set (map set (cnf_lists F)))" unfolding tcn ..
  also have "\<dots> = cnf_semantics_list \<A> (cnf_lists F)"
    unfolding cnf_semantics_def clause_semantics_def cnf_semantics_list_def by fastforce
  also have "\<dots> = \<A> \<Turnstile> (cnf_form_of F)" using nnf
    by(induction F rule: cnf_lists.induct;
       simp add: cnf_semantics_list_def cnf_form_of_defs  ball_Un bex_Un)
  finally show ?thesis by simp
qed

corollary "\<exists>G. \<A> \<Turnstile> F \<longleftrightarrow> \<A> \<Turnstile> G \<and> is_cnf G"
  using cnf_form_of_is cnf_form_semantics is_nnf_nnf nnf_semantics by blast

end


(* Author: Tobias Nipkow *)

section "AA Tree Implementation of Maps"

theory AA_Map
imports
  AA_Set
  Lookup2
begin

fun update :: "'a::linorder \<Rightarrow> 'b \<Rightarrow> ('a*'b) aa_tree \<Rightarrow> ('a*'b) aa_tree" where
"update x y Leaf = Node Leaf ((x,y), 1) Leaf" |
"update x y (Node t1 ((a,b), lv) t2) =
  (case cmp x a of
     LT \<Rightarrow> split (skew (Node (update x y t1) ((a,b), lv) t2)) |
     GT \<Rightarrow> split (skew (Node t1 ((a,b), lv) (update x y t2))) |
     EQ \<Rightarrow> Node t1 ((x,y), lv) t2)"

fun delete :: "'a::linorder \<Rightarrow> ('a*'b) aa_tree \<Rightarrow> ('a*'b) aa_tree" where
"delete _ Leaf = Leaf" |
"delete x (Node l ((a,b), lv) r) =
  (case cmp x a of
     LT \<Rightarrow> adjust (Node (delete x l) ((a,b), lv) r) |
     GT \<Rightarrow> adjust (Node l ((a,b), lv) (delete x r)) |
     EQ \<Rightarrow> (if l = Leaf then r
            else let (l',ab') = split_max l in adjust (Node l' (ab', lv) r)))"

subsection "Invariance"

subsubsection "Proofs for insert"

lemma lvl_update_aux:
  "lvl (update x y t) = lvl t \<or> lvl (update x y t) = lvl t + 1 \<and> sngl (update x y t)"
apply(induction t)
apply (auto simp: lvl_skew)
apply (metis Suc_eq_plus1 lvl.simps(2) lvl_split lvl_skew)+
done

lemma lvl_update: obtains
  (Same) "lvl (update x y t) = lvl t" |
  (Incr) "lvl (update x y t) = lvl t + 1" "sngl (update x y t)"
using lvl_update_aux by fastforce

declare invar.simps(2)[simp]

lemma lvl_update_sngl: "invar t \<Longrightarrow> sngl t \<Longrightarrow> lvl(update x y t) = lvl t"
proof (induction t rule: update.induct)
  case (2 x y t1 a b lv t2)
  consider (LT) "x < a" | (GT) "x > a" | (EQ) "x = a"
    using less_linear by blast
  thus ?case proof cases
    case LT
    thus ?thesis using 2 by (auto simp add: skew_case split_case split: tree.splits)
  next
    case GT
    thus ?thesis using 2 proof (cases t1)
      case Node
      thus ?thesis using 2 GT
        apply (auto simp add: skew_case split_case split: tree.splits)
        by (metis less_not_refl2 lvl.simps(2) lvl_update_aux n_not_Suc_n sngl.simps(3))+
    qed (auto simp add: lvl_0_iff)
  qed simp
qed simp

lemma lvl_update_incr_iff: "(lvl(update a b t) = lvl t + 1) \<longleftrightarrow>
  (\<exists>l x r. update a b t = Node l (x,lvl t + 1) r \<and> lvl l = lvl r)"
apply(cases t)
apply(auto simp add: skew_case split_case split: if_splits)
apply(auto split: tree.splits if_splits)
done

lemma invar_update: "invar t \<Longrightarrow> invar(update a b t)"
proof(induction t rule: tree2_induct)
  case N: (Node l xy n r)
  hence il: "invar l" and ir: "invar r" by auto
  note iil = N.IH(1)[OF il]
  note iir = N.IH(2)[OF ir]
  obtain x y where [simp]: "xy = (x,y)" by fastforce
  let ?t = "Node l (xy, n) r"
  have "a < x \<or> a = x \<or> x < a" by auto
  moreover
  have ?case if "a < x"
  proof (cases rule: lvl_update[of a b l])
    case (Same) thus ?thesis
      using \<open>a<x\<close> invar_NodeL[OF N.prems iil Same]
      by (simp add: skew_invar split_invar del: invar.simps)
  next
    case (Incr)
    then obtain t1 w t2 where ial[simp]: "update a b l = Node t1 (w, n) t2"
      using N.prems by (auto simp: lvl_Suc_iff)
    have l12: "lvl t1 = lvl t2"
      by (metis Incr(1) ial lvl_update_incr_iff tree.inject)
    have "update a b ?t = split(skew(Node (update a b l) (xy, n) r))"
      by(simp add: \<open>a<x\<close>)
    also have "skew(Node (update a b l) (xy, n) r) = Node t1 (w, n) (Node t2 (xy, n) r)"
      by(simp)
    also have "invar(split \<dots>)"
    proof (cases r rule: tree2_cases)
      case Leaf
      hence "l = Leaf" using N.prems by(auto simp: lvl_0_iff)
      thus ?thesis using Leaf ial by simp
    next
      case [simp]: (Node t3 y m t4)
      show ?thesis (*using N(3) iil l12 by(auto)*)
      proof cases
        assume "m = n" thus ?thesis using N(3) iil by(auto)
      next
        assume "m \<noteq> n" thus ?thesis using N(3) iil l12 by(auto)
      qed
    qed
    finally show ?thesis .
  qed
  moreover
  have ?case if "x < a"
  proof -
    from \<open>invar ?t\<close> have "n = lvl r \<or> n = lvl r + 1" by auto
    thus ?case
    proof
      assume 0: "n = lvl r"
      have "update a b ?t = split(skew(Node l (xy, n) (update a b r)))"
        using \<open>a>x\<close> by(auto)
      also have "skew(Node l (xy, n) (update a b r)) = Node l (xy, n) (update a b r)"
        using N.prems by(simp add: skew_case split: tree.split)
      also have "invar(split \<dots>)"
      proof -
        from lvl_update_sngl[OF ir sngl_if_invar[OF \<open>invar ?t\<close> 0], of a b]
        obtain t1 p t2 where iar: "update a b r = Node t1 (p, n) t2"
          using N.prems 0 by (auto simp: lvl_Suc_iff)
        from N.prems iar 0 iir
        show ?thesis by (auto simp: split_case split: tree.splits)
      qed
      finally show ?thesis .
    next
      assume 1: "n = lvl r + 1"
      hence "sngl ?t" by(cases r) auto
      show ?thesis
      proof (cases rule: lvl_update[of a b r])
        case (Same)
        show ?thesis using \<open>x<a\<close> il ir invar_NodeR[OF N.prems 1 iir Same]
          by (auto simp add: skew_invar split_invar)
      next
        case (Incr)
        thus ?thesis using invar_NodeR2[OF \<open>invar ?t\<close> Incr(2) 1 iir] 1 \<open>x < a\<close>
          by (auto simp add: skew_invar split_invar split: if_splits)
      qed
    qed
  qed
  moreover
  have "a = x \<Longrightarrow> ?case" using N.prems by auto
  ultimately show ?case by blast
qed simp

subsubsection "Proofs for delete"

declare invar.simps(2)[simp del]

theorem post_delete: "invar t \<Longrightarrow> post_del t (delete x t)"
proof (induction t  rule: tree2_induct)
  case (Node l ab lv r)

  obtain a b where [simp]: "ab = (a,b)" by fastforce

  let ?l' = "delete x l" and ?r' = "delete x r"
  let ?t = "Node l (ab, lv) r" let ?t' = "delete x ?t"

  from Node.prems have inv_l: "invar l" and inv_r: "invar r" by (auto)

  note post_l' = Node.IH(1)[OF inv_l]
  note preL = pre_adj_if_postL[OF Node.prems post_l']

  note post_r' = Node.IH(2)[OF inv_r]
  note preR = pre_adj_if_postR[OF Node.prems post_r']

  show ?case
  proof (cases rule: linorder_cases[of x a])
    case less
    thus ?thesis using Node.prems by (simp add: post_del_adjL preL)
  next
    case greater
    thus ?thesis using Node.prems preR by (simp add: post_del_adjR post_r')
  next
    case equal
    show ?thesis
    proof cases
      assume "l = Leaf" thus ?thesis using equal Node.prems
        by(auto simp: post_del_def invar.simps(2))
    next
      assume "l \<noteq> Leaf" thus ?thesis using equal Node.prems
        by simp (metis inv_l post_del_adjL post_split_max pre_adj_if_postL)
    qed
  qed
qed (simp add: post_del_def)

subsection \<open>Functional Correctness Proofs\<close>

theorem inorder_update:
  "sorted1(inorder t) \<Longrightarrow> inorder(update x y t) = upd_list x y (inorder t)"
by (induct t) (auto simp: upd_list_simps inorder_split inorder_skew)

theorem inorder_delete:
  "\<lbrakk>invar t; sorted1(inorder t)\<rbrakk> \<Longrightarrow>
  inorder (delete x t) = del_list x (inorder t)"
by(induction t)
  (auto simp: del_list_simps inorder_adjust pre_adj_if_postL pre_adj_if_postR
              post_split_max post_delete split_maxD split: prod.splits)

interpretation I: Map_by_Ordered
where empty = empty and lookup = lookup and update = update and delete = delete
and inorder = inorder and inv = invar
proof (standard, goal_cases)
  case 1 show ?case by (simp add: empty_def)
next
  case 2 thus ?case by(simp add: lookup_map_of)
next
  case 3 thus ?case by(simp add: inorder_update)
next
  case 4 thus ?case by(simp add: inorder_delete)
next
  case 5 thus ?case by(simp add: empty_def)
next
  case 6 thus ?case by(simp add: invar_update)
next
  case 7 thus ?case using post_delete by(auto simp: post_del_def)
qed

end


\<^marker>\<open>creator "Kevin Kappelmann"\<close>
paragraph \<open>Basic Setup and Results\<close>
theory Order_Functors_Base
  imports
    Functions_Inverse
    Order_Functions_Base
begin

text \<open>In the following, we do not add any assumptions to our locales but rather
add them as needed to the theorem statements. This allows consumers to
state preciser results; particularly, the development of Transport depends
on this setup.\<close>

locale orders =
  fixes L :: "'a \<Rightarrow> 'b \<Rightarrow> bool"
  and R :: "'c \<Rightarrow> 'd \<Rightarrow> bool"
begin

notation L (infix "\<le>\<^bsub>L\<^esub>" 50)
notation R (infix "\<le>\<^bsub>R\<^esub>" 50)

text\<open>We call @{term "(\<le>\<^bsub>L\<^esub>)"} the \<^emph>\<open>left relation\<close> and @{term "(\<le>\<^bsub>R\<^esub>)"} the
\<^emph>\<open>right relation\<close>.\<close>

abbreviation (input) "ge_left \<equiv> (\<le>\<^bsub>L\<^esub>)\<inverse>"
notation ge_left (infix "\<ge>\<^bsub>L\<^esub>" 50)

abbreviation (input) "ge_right \<equiv> (\<le>\<^bsub>R\<^esub>)\<inverse>"
notation ge_right (infix "\<ge>\<^bsub>R\<^esub>" 50)

end

text \<open>Homogeneous orders\<close>
locale hom_orders = orders L R
  for L :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
  and R :: "'b \<Rightarrow> 'b \<Rightarrow> bool"

locale order_functor = hom_orders L R
  for L :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
  and R :: "'b \<Rightarrow> 'b \<Rightarrow> bool"
  and l :: "'a \<Rightarrow> 'b"
begin

lemma left_right_rel_left_self_if_reflexive_on_left_if_mono_left:
  assumes "((\<le>\<^bsub>L\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>R\<^esub>)) l"
  and "reflexive_on P (\<le>\<^bsub>L\<^esub>)"
  and "P x"
  shows "l x \<le>\<^bsub>R\<^esub> l x"
  using assms by blast

lemma left_right_rel_left_self_if_reflexive_on_in_dom_right_if_mono_left:
  assumes "((\<le>\<^bsub>L\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>R\<^esub>)) l"
  and "reflexive_on (in_dom (\<le>\<^bsub>R\<^esub>)) (\<le>\<^bsub>R\<^esub>)"
  and "in_dom (\<le>\<^bsub>L\<^esub>) x"
  shows "l x \<le>\<^bsub>R\<^esub> l x"
  using assms by blast

lemma left_right_rel_left_self_if_reflexive_on_in_codom_right_if_mono_left:
  assumes "((\<le>\<^bsub>L\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>R\<^esub>)) l"
  and "reflexive_on (in_codom (\<le>\<^bsub>R\<^esub>)) (\<le>\<^bsub>R\<^esub>)"
  and "in_codom (\<le>\<^bsub>L\<^esub>) x"
  shows "l x \<le>\<^bsub>R\<^esub> l x"
  using assms by blast

lemma left_right_rel_left_self_if_reflexive_on_in_field_right_if_mono_left:
  assumes "((\<le>\<^bsub>L\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>R\<^esub>)) l"
  and "reflexive_on (in_field (\<le>\<^bsub>R\<^esub>)) (\<le>\<^bsub>R\<^esub>)"
  and "in_field (\<le>\<^bsub>L\<^esub>) x"
  shows "l x \<le>\<^bsub>R\<^esub> l x"
  using assms by blast

lemma mono_wrt_rel_left_if_reflexive_on_if_le_eq_if_mono_wrt_in_field:
  assumes "([in_field (\<le>\<^bsub>L\<^esub>)] \<Rrightarrow>\<^sub>m P) l"
  and "(\<le>\<^bsub>L\<^esub>) \<le> (=)"
  and "reflexive_on P (\<le>\<^bsub>R\<^esub>)"
  shows "((\<le>\<^bsub>L\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>R\<^esub>)) l"
  using assms by (intro dep_mono_wrt_relI) auto

end

locale order_functors = order_functor L R l + flip_of : order_functor R L r
  for L R l r
begin

text \<open>We call the composition \<^term>\<open>r \<circ> l\<close> the \<^emph>\<open>unit\<close>
and the term \<^term>\<open>l \<circ> r\<close> the \<^emph>\<open>counit\<close> of the order functors pair.
This is terminology is borrowed from category theory \<hyphen> the functors
are an \<^emph>\<open>adjoint\<close>.\<close>

definition "unit \<equiv> r \<circ> l"

notation unit ("\<eta>")

lemma unit_eq_comp: "\<eta> = r \<circ> l" unfolding unit_def by simp

lemma unit_eq [simp]: "\<eta> x = r (l x)" by (simp add: unit_eq_comp)

context
begin

text \<open>Note that by flipping the roles of the left and rights functors,
we obtain a flipped interpretation of @{locale order_functors}.
In many cases, this allows us to obtain symmetric definitions and theorems for free.
As such, in many cases, we do we do not explicitly state those free results but
users can obtain them as needed by creating said flipped interpretation.\<close>

interpretation flip : order_functors R L r l .

definition "counit \<equiv> flip.unit"

notation counit ("\<epsilon>")

lemma counit_eq_comp: "\<epsilon> = l \<circ> r" unfolding counit_def flip.unit_def by simp

lemma counit_eq [simp]: "\<epsilon> x = l (r x)" by (simp add: counit_eq_comp)

end

context
begin

interpretation flip : order_functors R L r l .

lemma flip_counit_eq_unit: "flip.counit = \<eta>"
  by (intro ext) simp

lemma flip_unit_eq_counit: "flip.unit = \<epsilon>"
  by (intro ext) simp

lemma inflationary_on_unit_if_left_rel_right_if_left_right_relI:
  assumes "((\<le>\<^bsub>L\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>R\<^esub>)) l"
  and "reflexive_on P (\<le>\<^bsub>L\<^esub>)"
  and "\<And>x y. P x \<Longrightarrow> l x \<le>\<^bsub>R\<^esub> y \<Longrightarrow> x \<le>\<^bsub>L\<^esub> r y"
  shows "inflationary_on P (\<le>\<^bsub>L\<^esub>) \<eta>"
  using assms by (intro inflationary_onI) auto

lemma deflationary_on_unit_if_right_left_rel_if_right_rel_leftI:
  assumes "((\<le>\<^bsub>L\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>R\<^esub>)) l"
  and "reflexive_on P (\<le>\<^bsub>L\<^esub>)"
  and "\<And>x y. P x \<Longrightarrow> y \<le>\<^bsub>R\<^esub> l x \<Longrightarrow> r y \<le>\<^bsub>L\<^esub> x"
  shows "deflationary_on P (\<le>\<^bsub>L\<^esub>) \<eta>"
  using assms by (intro deflationary_onI) auto

context
  fixes P :: "'a \<Rightarrow> bool"
begin

lemma rel_equivalence_on_unit_iff_inflationary_on_if_inverse_on:
  assumes "inverse_on P l r"
  shows "rel_equivalence_on P (\<le>\<^bsub>L\<^esub>) \<eta> \<longleftrightarrow> inflationary_on P (\<le>\<^bsub>L\<^esub>) \<eta>"
  using assms by (intro iffI rel_equivalence_onI inflationary_onI deflationary_onI)
  (auto dest!: inverse_onD)

lemma reflexive_on_left_if_inflationary_on_unit_if_inverse_on:
  assumes "inverse_on P l r"
  and "inflationary_on P (\<le>\<^bsub>L\<^esub>) \<eta>"
  shows "reflexive_on P (\<le>\<^bsub>L\<^esub>)"
  using assms by (intro reflexive_onI) (auto dest!: inverse_onD)

lemma rel_equivalence_on_unit_if_reflexive_on_if_inverse_on:
  assumes "inverse_on P l r"
  and "reflexive_on P (\<le>\<^bsub>L\<^esub>)"
  shows "rel_equivalence_on P (\<le>\<^bsub>L\<^esub>) \<eta>"
  using assms by (intro rel_equivalence_onI inflationary_onI deflationary_onI)
  (auto dest!: inverse_onD)

end

corollary rel_equivalence_on_unit_iff_reflexive_on_if_inverse_on:
  fixes P :: "'a \<Rightarrow> bool"
  assumes "inverse_on P l r"
  shows "rel_equivalence_on P (\<le>\<^bsub>L\<^esub>) \<eta> \<longleftrightarrow> reflexive_on P (\<le>\<^bsub>L\<^esub>)"
  using assms reflexive_on_left_if_inflationary_on_unit_if_inverse_on
    rel_equivalence_on_unit_if_reflexive_on_if_inverse_on
  by (intro iffI) auto

end

text \<open>Here is an example of a free theorem.\<close>

notepad
begin
  interpret flip : order_functors R L r l
    rewrites "flip.unit \<equiv> \<epsilon>" by (simp only: flip_unit_eq_counit)
  have "\<lbrakk>((\<le>\<^bsub>R\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>L\<^esub>)) r; reflexive_on P (\<le>\<^bsub>R\<^esub>); \<And>x y. \<lbrakk>P x; r x \<le>\<^bsub>L\<^esub> y\<rbrakk> \<Longrightarrow> x \<le>\<^bsub>R\<^esub> l y\<rbrakk>
      \<Longrightarrow> inflationary_on P (\<le>\<^bsub>R\<^esub>) \<epsilon>" for P
    by (fact flip.inflationary_on_unit_if_left_rel_right_if_left_right_relI)
end

end

end


(*  Title:      HOL/Nunchaku_Examples/Manual_Nuns.thy
    Author:     Jasmin Blanchette, Inria Nancy, LORIA, MPII
    Copyright   2009-2014

Examples from the Nunchaku manual.
*)

section {* Examples from the Nunchaku Manual *}

(* The "expect" arguments to Nunchaku in this and other theory files are there because the files
   also serve as a regression test suite. *)

theory Manual_Nuns
imports Real "~~/src/HOL/Library/Quotient_Product" "../Nunchaku"
begin

subsection {* 2. First Steps *}

nunchaku_params [timeout = 240]

subsubsection {* 2.1. Propositional Logic *}

lemma "P \<longleftrightarrow> Q"
nunchaku [expect = genuine]
apply auto
nunchaku [expect = genuine] 1
nunchaku [expect = genuine] 2
oops

subsubsection {* 2.2. Type Variables *}

lemma "x \<in> A \<Longrightarrow> (THE y. y \<in> A) \<in> A"
nunchaku [verbose, expect = genuine]
oops

subsubsection {* 2.3. Constants *}

lemma "x \<in> A \<Longrightarrow> (THE y. y \<in> A) \<in> A"
nunchaku [show_consts, expect = genuine]
nunchaku [dont_specialize, show_consts, expect = genuine]
oops

lemma "\<exists>!x. x \<in> A \<Longrightarrow> (THE y. y \<in> A) \<in> A"
nunchaku [expect = none]
(* sledgehammer *)
by (metis the_equality)

subsubsection {* 2.4. Skolemization *}

lemma "\<exists>g. \<forall>x. g (f x) = x \<Longrightarrow> \<forall>y. \<exists>x. y = f x"
nunchaku [expect = genuine]
oops

lemma "\<exists>x. \<forall>f. f x = x"
nunchaku [expect = genuine]
oops

lemma "refl r \<Longrightarrow> sym r"
nunchaku [expect = genuine]
oops

subsubsection {* 2.5. Natural Numbers and Integers *}

lemma "\<lbrakk>i \<le> j; n \<le> (m :: int)\<rbrakk> \<Longrightarrow> i * n + j * m \<le> i * m + j * n"
nunchaku [expect = genuine]
oops

lemma "(\<forall>n. Suc n \<noteq> n) \<Longrightarrow> P"
nunchaku [timeout = 5, expect = potential]
oops

lemma "P Suc"
nunchaku [expect = genuine]
oops

lemma "P (op + :: nat \<Rightarrow> nat \<Rightarrow> nat)"
nunchaku [expect = genuine]
oops

subsubsection {* 2.6. Inductive Datatypes *}

lemma "hd (xs @ [y, y]) = hd xs"
nunchaku [expect = genuine]
nunchaku [show_consts, expect = genuine]
oops

lemma "\<lbrakk>length xs = 1; length ys = 1\<rbrakk> \<Longrightarrow> xs = ys"
nunchaku [expect = genuine]
oops

subsubsection {* 2.7. Typedefs, Records, Rationals, and Reals *}

definition "three = {0 :: nat, 1, 2}"
typedef three = three
  unfolding three_def by blast

definition A :: three where "A \<equiv> Abs_three 0"
definition B :: three where "B \<equiv> Abs_three 1"
definition C :: three where "C \<equiv> Abs_three 2"

lemma "\<lbrakk>A \<in> X; B \<in> X\<rbrakk> \<Longrightarrow> c \<in> X"
nunchaku [expect = genuine]
oops

fun my_int_rel where
  "my_int_rel (x, y) (u, v) = (x + v = u + y)"

quotient_type my_int = "nat \<times> nat" / my_int_rel
by (auto simp add: equivp_def fun_eq_iff)

definition add_raw where
  "add_raw \<equiv> \<lambda>(x, y) (u, v). (x + (u :: nat), y + (v :: nat))"

quotient_definition "add :: my_int \<Rightarrow> my_int \<Rightarrow> my_int" is add_raw
unfolding add_raw_def by auto

lemma "add x y = add x x"
nunchaku [expect = genuine]
oops

record point =
  Xcoord :: int
  Ycoord :: int

lemma "Xcoord (p :: point) = Xcoord (q :: point)"
nunchaku [expect = genuine]
oops

lemma "4 * x + 3 * (y :: real) \<noteq> 1 / 2"
nunchaku [expect = genuine]
oops

subsubsection {* 2.8. Inductive and Coinductive Predicates *}

inductive even where
  "even 0"
| "even n \<Longrightarrow> even (Suc (Suc n))"

lemma "\<exists>n. even n \<and> even (Suc n)"
nunchaku [timeout = 5, expect = potential]
oops

lemma "\<exists>n \<le> 49. even n \<and> even (Suc n)"
nunchaku [expect = genuine]
oops

inductive even' where
  "even' (0 :: nat)"
| "even' 2"
| "\<lbrakk>even' m; even' n\<rbrakk> \<Longrightarrow> even' (m + n)"

lemma "\<exists>n \<in> {0, 2, 4, 6, 8}. \<not> even' n"
nunchaku [verbose, show_consts, expect = genuine]
oops

lemma "even' (n - 2) \<Longrightarrow> even' n"
nunchaku [show_consts, expect = genuine]
oops

coinductive nats where
  "nats (x :: nat) \<Longrightarrow> nats x"

lemma "nats = (\<lambda>n. n \<in> {0, 1, 2, 3, 4})"
nunchaku [show_consts, expect = genuine]
oops

inductive odd where
  "odd 1"
| "\<lbrakk>odd m; even n\<rbrakk> \<Longrightarrow> odd (m + n)"

lemma "odd n \<Longrightarrow> odd (n - 2)"
nunchaku [show_consts, expect = genuine]
oops

subsubsection {* 2.9. Coinductive Datatypes *}

codatatype 'a llist = LNil | LCons 'a "'a llist"

primcorec iterates where
  "iterates f a = LCons a (iterates f (f a))"

lemma "xs \<noteq> LCons a xs"
nunchaku [expect = genuine]
oops

lemma "\<lbrakk>xs = LCons a xs; ys = iterates (\<lambda>b. a) b\<rbrakk> \<Longrightarrow> xs = ys"
nunchaku [verbose, expect = genuine]
oops

lemma "\<lbrakk>xs = LCons a xs; ys = LCons a ys\<rbrakk> \<Longrightarrow> xs = ys"
nunchaku [expect = none]
sorry

subsubsection {* 2.10. Boxing *}

datatype tm =
  Var nat
| Lam tm
| App tm tm

primrec lift where
  "lift (Var j) k = Var (if j < k then j else j + 1)"
| "lift (Lam t) k = Lam (lift t (k + 1))"
| "lift (App t u) k = App (lift t k) (lift u k)"

primrec loose where
  "loose (Var j) k = (j \<ge> k)"
| "loose (Lam t) k = loose t (Suc k)"
| "loose (App t u) k = (loose t k \<or> loose u k)"

primrec subst\<^sub>1 where
  "subst\<^sub>1 \<sigma> (Var j) = \<sigma> j"
| "subst\<^sub>1 \<sigma> (Lam t) = Lam (subst\<^sub>1 (\<lambda>n. case n of 0 \<Rightarrow> Var 0 | Suc m \<Rightarrow> lift (\<sigma> m) 1) t)"
| "subst\<^sub>1 \<sigma> (App t u) = App (subst\<^sub>1 \<sigma> t) (subst\<^sub>1 \<sigma> u)"

lemma "\<not> loose t 0 \<Longrightarrow> subst\<^sub>1 \<sigma> t = t"
nunchaku [verbose, expect = genuine]
nunchaku [eval = "subst\<^sub>1 \<sigma> t", expect = genuine]
oops

primrec subst\<^sub>2 where
  "subst\<^sub>2 \<sigma> (Var j) = \<sigma> j"
| "subst\<^sub>2 \<sigma> (Lam t) = Lam (subst\<^sub>2 (\<lambda>n. case n of 0 \<Rightarrow> Var 0 | Suc m \<Rightarrow> lift (\<sigma> m) 0) t)"
| "subst\<^sub>2 \<sigma> (App t u) = App (subst\<^sub>2 \<sigma> t) (subst\<^sub>2 \<sigma> u)"

lemma "\<not> loose t 0 \<Longrightarrow> subst\<^sub>2 \<sigma> t = t"
nunchaku [expect = none]
sorry

subsubsection {* 2.11. Scope Monotonicity *}

lemma "length xs = length ys \<Longrightarrow> rev (zip xs ys) = zip xs (rev ys)"
nunchaku [verbose, expect = genuine]
oops

lemma "\<exists>g. \<forall>x :: 'b. g (f x) = x \<Longrightarrow> \<forall>y :: 'a. \<exists>x. y = f x"
nunchaku [expect = genuine]
oops

subsubsection {* 2.12. Inductive Properties *}

inductive_set reach where
"(4 :: nat) \<in> reach" |
"n \<in> reach \<Longrightarrow> n < 4 \<Longrightarrow> 3 * n + 1 \<in> reach" |
"n \<in> reach \<Longrightarrow> n + 2 \<in> reach"

lemma "n \<in> reach \<Longrightarrow> 2 dvd n"
(* nunchaku *)
apply (induct set: reach)
  apply auto
 nunchaku [timeout = 5, expect = unknown]
 apply (thin_tac "n \<in> reach")
 nunchaku [expect = genuine]
oops

lemma "n \<in> reach \<Longrightarrow> 2 dvd n \<and> n \<noteq> 0"
(* nunchaku *)
apply (induct set: reach)
  apply auto
 nunchaku [timeout = 5, expect = unknown]
 apply (thin_tac "n \<in> reach")
 nunchaku [expect = genuine]
oops

lemma "n \<in> reach \<Longrightarrow> 2 dvd n \<and> n \<ge> 4"
by (induct set: reach) arith+

subsection {* 3. Case Studies *}

nunchaku_params [max_potential = 0]

subsubsection {* 3.1. A Context-Free Grammar *}

datatype alphabet = a | b

inductive_set S\<^sub>1 and A\<^sub>1 and B\<^sub>1 where
  "[] \<in> S\<^sub>1"
| "w \<in> A\<^sub>1 \<Longrightarrow> b # w \<in> S\<^sub>1"
| "w \<in> B\<^sub>1 \<Longrightarrow> a # w \<in> S\<^sub>1"
| "w \<in> S\<^sub>1 \<Longrightarrow> a # w \<in> A\<^sub>1"
| "w \<in> S\<^sub>1 \<Longrightarrow> b # w \<in> S\<^sub>1"
| "\<lbrakk>v \<in> B\<^sub>1; v \<in> B\<^sub>1\<rbrakk> \<Longrightarrow> a # v @ w \<in> B\<^sub>1"

theorem S\<^sub>1_sound:
"w \<in> S\<^sub>1 \<longrightarrow> length [x \<leftarrow> w. x = a] = length [x \<leftarrow> w. x = b]"
nunchaku [expect = genuine]
oops

inductive_set S\<^sub>2 and A\<^sub>2 and B\<^sub>2 where
  "[] \<in> S\<^sub>2"
| "w \<in> A\<^sub>2 \<Longrightarrow> b # w \<in> S\<^sub>2"
| "w \<in> B\<^sub>2 \<Longrightarrow> a # w \<in> S\<^sub>2"
| "w \<in> S\<^sub>2 \<Longrightarrow> a # w \<in> A\<^sub>2"
| "w \<in> S\<^sub>2 \<Longrightarrow> b # w \<in> B\<^sub>2"
| "\<lbrakk>v \<in> B\<^sub>2; v \<in> B\<^sub>2\<rbrakk> \<Longrightarrow> a # v @ w \<in> B\<^sub>2"

theorem S\<^sub>2_sound:
"w \<in> S\<^sub>2 \<longrightarrow> length [x \<leftarrow> w. x = a] = length [x \<leftarrow> w. x = b]"
nunchaku [expect = genuine]
oops

inductive_set S\<^sub>3 and A\<^sub>3 and B\<^sub>3 where
  "[] \<in> S\<^sub>3"
| "w \<in> A\<^sub>3 \<Longrightarrow> b # w \<in> S\<^sub>3"
| "w \<in> B\<^sub>3 \<Longrightarrow> a # w \<in> S\<^sub>3"
| "w \<in> S\<^sub>3 \<Longrightarrow> a # w \<in> A\<^sub>3"
| "w \<in> S\<^sub>3 \<Longrightarrow> b # w \<in> B\<^sub>3"
| "\<lbrakk>v \<in> B\<^sub>3; w \<in> B\<^sub>3\<rbrakk> \<Longrightarrow> a # v @ w \<in> B\<^sub>3"

theorem S\<^sub>3_sound:
"w \<in> S\<^sub>3 \<longrightarrow> length [x \<leftarrow> w. x = a] = length [x \<leftarrow> w. x = b]"
nunchaku [expect = none]
sorry

theorem S\<^sub>3_complete:
"length [x \<leftarrow> w. x = a] = length [x \<leftarrow> w. x = b] \<longrightarrow> w \<in> S\<^sub>3"
nunchaku [expect = genuine]
oops

inductive_set S\<^sub>4 and A\<^sub>4 and B\<^sub>4 where
  "[] \<in> S\<^sub>4"
| "w \<in> A\<^sub>4 \<Longrightarrow> b # w \<in> S\<^sub>4"
| "w \<in> B\<^sub>4 \<Longrightarrow> a # w \<in> S\<^sub>4"
| "w \<in> S\<^sub>4 \<Longrightarrow> a # w \<in> A\<^sub>4"
| "\<lbrakk>v \<in> A\<^sub>4; w \<in> A\<^sub>4\<rbrakk> \<Longrightarrow> b # v @ w \<in> A\<^sub>4"
| "w \<in> S\<^sub>4 \<Longrightarrow> b # w \<in> B\<^sub>4"
| "\<lbrakk>v \<in> B\<^sub>4; w \<in> B\<^sub>4\<rbrakk> \<Longrightarrow> a # v @ w \<in> B\<^sub>4"

theorem S\<^sub>4_sound:
"w \<in> S\<^sub>4 \<longrightarrow> length [x \<leftarrow> w. x = a] = length [x \<leftarrow> w. x = b]"
nunchaku [expect = none]
sorry

theorem S\<^sub>4_complete:
"length [x \<leftarrow> w. x = a] = length [x \<leftarrow> w. x = b] \<longrightarrow> w \<in> S\<^sub>4"
nunchaku [expect = none]
sorry

theorem S\<^sub>4_A\<^sub>4_B\<^sub>4_sound_and_complete:
"w \<in> S\<^sub>4 \<longleftrightarrow> length [x \<leftarrow> w. x = a] = length [x \<leftarrow> w. x = b]"
"w \<in> A\<^sub>4 \<longleftrightarrow> length [x \<leftarrow> w. x = a] = length [x \<leftarrow> w. x = b] + 1"
"w \<in> B\<^sub>4 \<longleftrightarrow> length [x \<leftarrow> w. x = b] = length [x \<leftarrow> w. x = a] + 1"
nunchaku [expect = none]
sorry

subsubsection {* 3.2. AA Trees *}

datatype 'a aa_tree = \<Lambda> | N "'a :: linorder" nat "'a aa_tree" "'a aa_tree"

primrec data where
  "data \<Lambda> = undefined"
| "data (N x _ _ _) = x"

primrec dataset where
  "dataset \<Lambda> = {}"
| "dataset (N x _ t u) = {x} \<union> dataset t \<union> dataset u"

primrec level where
  "level \<Lambda> = 0"
| "level (N _ k _ _) = k"

primrec left where
  "left \<Lambda> = \<Lambda>"
| "left (N _ _ t\<^sub>1 _) = t\<^sub>1"

primrec right where
  "right \<Lambda> = \<Lambda>"
| "right (N _ _ _ t\<^sub>2) = t\<^sub>2"

fun wf where
  "wf \<Lambda> = True"
| "wf (N _ k t u) =
   (if t = \<Lambda> then k = 1 \<and> (u = \<Lambda> \<or> (level u = 1 \<and> left u = \<Lambda> \<and> right u = \<Lambda>))
    else wf t \<and> wf u \<and> u \<noteq> \<Lambda> \<and> level t < k \<and> level u \<le> k \<and> level (right u) < k)"

fun skew where
  "skew \<Lambda> = \<Lambda>"
| "skew (N x k t u) =
   (if t \<noteq> \<Lambda> \<and> k = level t then N (data t) k (left t) (N x k (right t) u)
    else N x k t u)"

fun split where
  "split \<Lambda> = \<Lambda>"
| "split (N x k t u) =
   (if u \<noteq> \<Lambda> \<and> k = level (right u) then N (data u) (Suc k) (N x k t (left u)) (right u)
    else N x k t u)"

theorem dataset_skew_split:
  "dataset (skew t) = dataset t"
  "dataset (split t) = dataset t"
nunchaku [expect = none]
sorry

theorem wf_skew_split:
  "wf t \<Longrightarrow> skew t = t"
  "wf t \<Longrightarrow> split t = t"
nunchaku [expect = none]
sorry

primrec insort\<^sub>1 where
  "insort\<^sub>1 \<Lambda> x = N x 1 \<Lambda> \<Lambda>"
| "insort\<^sub>1 (N y k t u) x =
   (* (split \<circ> skew) *)
   (N y k (if x < y then insort\<^sub>1 t x else t) (if x > y then insort\<^sub>1 u x else u))"

theorem wf_insort\<^sub>1: "wf t \<Longrightarrow> wf (insort\<^sub>1 t x)"
nunchaku [expect = genuine]
oops

theorem wf_insort\<^sub>1_nat:
"wf t \<Longrightarrow>
t = N 1 1 \<Lambda> \<Lambda> \<Longrightarrow>
x = 0 \<Longrightarrow>
wf (insort\<^sub>1 t (x :: nat))"
nunchaku [eval = "insort\<^sub>1 t x", expect = genuine]
oops

primrec insort\<^sub>2 where
"insort\<^sub>2 \<Lambda> x = N x 1 \<Lambda> \<Lambda>" |
"insort\<^sub>2 (N y k t u) x =
 (split \<circ> skew) (N y k (if x < y then insort\<^sub>2 t x else t)
                       (if x > y then insort\<^sub>2 u x else u))"

theorem wf_insort\<^sub>2: "wf t \<Longrightarrow> wf (insort\<^sub>2 t x)"
nunchaku [expect = none]
sorry

theorem dataset_insort\<^sub>2: "dataset (insort\<^sub>2 t x) = {x} \<union> dataset t"
nunchaku [expect = none]
sorry

end


(*  Title:      HOL/Proofs/Lambda/Lambda.thy
    Author:     Tobias Nipkow
    Copyright   1995 TU Muenchen
*)

section {* Basic definitions of Lambda-calculus *}

theory Lambda
imports Main
begin

declare [[syntax_ambiguity_warning = false]]

subsection {* Lambda-terms in de Bruijn notation and substitution *}

datatype dB =
    Var nat
  | App dB dB (infixl "\<degree>" 200)
  | Abs dB

primrec
  lift :: "[dB, nat] => dB"
where
    "lift (Var i) k = (if i < k then Var i else Var (i + 1))"
  | "lift (s \<degree> t) k = lift s k \<degree> lift t k"
  | "lift (Abs s) k = Abs (lift s (k + 1))"

primrec
  subst :: "[dB, dB, nat] => dB"  ("_[_'/_]" [300, 0, 0] 300)
where (* FIXME base names *)
    subst_Var: "(Var i)[s/k] =
      (if k < i then Var (i - 1) else if i = k then s else Var i)"
  | subst_App: "(t \<degree> u)[s/k] = t[s/k] \<degree> u[s/k]"
  | subst_Abs: "(Abs t)[s/k] = Abs (t[lift s 0 / k+1])"

declare subst_Var [simp del]

text {* Optimized versions of @{term subst} and @{term lift}. *}

primrec
  liftn :: "[nat, dB, nat] => dB"
where
    "liftn n (Var i) k = (if i < k then Var i else Var (i + n))"
  | "liftn n (s \<degree> t) k = liftn n s k \<degree> liftn n t k"
  | "liftn n (Abs s) k = Abs (liftn n s (k + 1))"

primrec
  substn :: "[dB, dB, nat] => dB"
where
    "substn (Var i) s k =
      (if k < i then Var (i - 1) else if i = k then liftn k s 0 else Var i)"
  | "substn (t \<degree> u) s k = substn t s k \<degree> substn u s k"
  | "substn (Abs t) s k = Abs (substn t s (k + 1))"

subsection {* Beta-reduction *}

inductive beta :: "[dB, dB] => bool"  (infixl "\<rightarrow>\<^sub>\<beta>" 50)
  where
    beta [simp, intro!]: "Abs s \<degree> t \<rightarrow>\<^sub>\<beta> s[t/0]"
  | appL [simp, intro!]: "s \<rightarrow>\<^sub>\<beta> t ==> s \<degree> u \<rightarrow>\<^sub>\<beta> t \<degree> u"
  | appR [simp, intro!]: "s \<rightarrow>\<^sub>\<beta> t ==> u \<degree> s \<rightarrow>\<^sub>\<beta> u \<degree> t"
  | abs [simp, intro!]: "s \<rightarrow>\<^sub>\<beta> t ==> Abs s \<rightarrow>\<^sub>\<beta> Abs t"

abbreviation
  beta_reds :: "[dB, dB] => bool"  (infixl "->>" 50) where
  "s ->> t == beta^** s t"

notation (latex)
  beta_reds  (infixl "\<rightarrow>\<^sub>\<beta>\<^sup>*" 50)

inductive_cases beta_cases [elim!]:
  "Var i \<rightarrow>\<^sub>\<beta> t"
  "Abs r \<rightarrow>\<^sub>\<beta> s"
  "s \<degree> t \<rightarrow>\<^sub>\<beta> u"

declare if_not_P [simp] not_less_eq [simp]
  -- {* don't add @{text "r_into_rtrancl[intro!]"} *}

subsection {* Congruence rules *}

lemma rtrancl_beta_Abs [intro!]:
    "s \<rightarrow>\<^sub>\<beta>\<^sup>* s' ==> Abs s \<rightarrow>\<^sub>\<beta>\<^sup>* Abs s'"
  by (induct set: rtranclp) (blast intro: rtranclp.rtrancl_into_rtrancl)+

lemma rtrancl_beta_AppL:
    "s \<rightarrow>\<^sub>\<beta>\<^sup>* s' ==> s \<degree> t \<rightarrow>\<^sub>\<beta>\<^sup>* s' \<degree> t"
  by (induct set: rtranclp) (blast intro: rtranclp.rtrancl_into_rtrancl)+

lemma rtrancl_beta_AppR:
    "t \<rightarrow>\<^sub>\<beta>\<^sup>* t' ==> s \<degree> t \<rightarrow>\<^sub>\<beta>\<^sup>* s \<degree> t'"
  by (induct set: rtranclp) (blast intro: rtranclp.rtrancl_into_rtrancl)+

lemma rtrancl_beta_App [intro]:
    "[| s \<rightarrow>\<^sub>\<beta>\<^sup>* s'; t \<rightarrow>\<^sub>\<beta>\<^sup>* t' |] ==> s \<degree> t \<rightarrow>\<^sub>\<beta>\<^sup>* s' \<degree> t'"
  by (blast intro!: rtrancl_beta_AppL rtrancl_beta_AppR intro: rtranclp_trans)

subsection {* Substitution-lemmas *}

lemma subst_eq [simp]: "(Var k)[u/k] = u"
  by (simp add: subst_Var)

lemma subst_gt [simp]: "i < j ==> (Var j)[u/i] = Var (j - 1)"
  by (simp add: subst_Var)

lemma subst_lt [simp]: "j < i ==> (Var j)[u/i] = Var j"
  by (simp add: subst_Var)

lemma lift_lift:
    "i < k + 1 \<Longrightarrow> lift (lift t i) (Suc k) = lift (lift t k) i"
  by (induct t arbitrary: i k) auto

lemma lift_subst [simp]:
    "j < i + 1 \<Longrightarrow> lift (t[s/j]) i = (lift t (i + 1)) [lift s i / j]"
  by (induct t arbitrary: i j s)
    (simp_all add: diff_Suc subst_Var lift_lift split: nat.split)

lemma lift_subst_lt:
    "i < j + 1 \<Longrightarrow> lift (t[s/j]) i = (lift t i) [lift s i / j + 1]"
  by (induct t arbitrary: i j s) (simp_all add: subst_Var lift_lift)

lemma subst_lift [simp]:
    "(lift t k)[s/k] = t"
  by (induct t arbitrary: k s) simp_all

lemma subst_subst:
    "i < j + 1 \<Longrightarrow> t[lift v i / Suc j][u[v/j]/i] = t[u/i][v/j]"
  by (induct t arbitrary: i j u v)
    (simp_all add: diff_Suc subst_Var lift_lift [symmetric] lift_subst_lt
      split: nat.split)

subsection {* Equivalence proof for optimized substitution *}

lemma liftn_0 [simp]: "liftn 0 t k = t"
  by (induct t arbitrary: k) (simp_all add: subst_Var)

lemma liftn_lift [simp]: "liftn (Suc n) t k = lift (liftn n t k) k"
  by (induct t arbitrary: k) (simp_all add: subst_Var)

lemma substn_subst_n [simp]: "substn t s n = t[liftn n s 0 / n]"
  by (induct t arbitrary: n) (simp_all add: subst_Var)

theorem substn_subst_0: "substn t s 0 = t[s/0]"
  by simp

subsection {* Preservation theorems *}

text {* Not used in Church-Rosser proof, but in Strong
  Normalization. \medskip *}

theorem subst_preserves_beta [simp]:
    "r \<rightarrow>\<^sub>\<beta> s ==> r[t/i] \<rightarrow>\<^sub>\<beta> s[t/i]"
  by (induct arbitrary: t i set: beta) (simp_all add: subst_subst [symmetric])

theorem subst_preserves_beta': "r \<rightarrow>\<^sub>\<beta>\<^sup>* s ==> r[t/i] \<rightarrow>\<^sub>\<beta>\<^sup>* s[t/i]"
  apply (induct set: rtranclp)
   apply (rule rtranclp.rtrancl_refl)
  apply (erule rtranclp.rtrancl_into_rtrancl)
  apply (erule subst_preserves_beta)
  done

theorem lift_preserves_beta [simp]:
    "r \<rightarrow>\<^sub>\<beta> s ==> lift r i \<rightarrow>\<^sub>\<beta> lift s i"
  by (induct arbitrary: i set: beta) auto

theorem lift_preserves_beta': "r \<rightarrow>\<^sub>\<beta>\<^sup>* s ==> lift r i \<rightarrow>\<^sub>\<beta>\<^sup>* lift s i"
  apply (induct set: rtranclp)
   apply (rule rtranclp.rtrancl_refl)
  apply (erule rtranclp.rtrancl_into_rtrancl)
  apply (erule lift_preserves_beta)
  done

theorem subst_preserves_beta2 [simp]: "r \<rightarrow>\<^sub>\<beta> s ==> t[r/i] \<rightarrow>\<^sub>\<beta>\<^sup>* t[s/i]"
  apply (induct t arbitrary: r s i)
    apply (simp add: subst_Var r_into_rtranclp)
   apply (simp add: rtrancl_beta_App)
  apply (simp add: rtrancl_beta_Abs)
  done

theorem subst_preserves_beta2': "r \<rightarrow>\<^sub>\<beta>\<^sup>* s ==> t[r/i] \<rightarrow>\<^sub>\<beta>\<^sup>* t[s/i]"
  apply (induct set: rtranclp)
   apply (rule rtranclp.rtrancl_refl)
  apply (erule rtranclp_trans)
  apply (erule subst_preserves_beta2)
  done

end


(*
    Authors:      Jose Divasón
                  Sebastiaan Joosten
                  René Thiemann
                  Akihisa Yamada
*)
section \<open>Finite Rings and Fields\<close>

text \<open>We start by establishing some preliminary results about finite rings and finite fields\<close>

subsection \<open>Finite Rings\<close>

theory Finite_Field
imports
  "HOL-Computational_Algebra.Primes"
  "HOL-Number_Theory.Residues"
  "HOL-Library.Cardinality"
  Subresultants.Binary_Exponentiation
  Polynomial_Interpolation.Ring_Hom_Poly
begin

typedef ('a::finite) mod_ring = "{0..<int CARD('a)}" by auto

setup_lifting type_definition_mod_ring

lemma CARD_mod_ring[simp]: "CARD('a mod_ring) = CARD('a::finite)"
proof -
  have "card {y. \<exists>x\<in>{0..<int CARD('a)}. (y::'a mod_ring) = Abs_mod_ring x} = card {0..<int CARD('a)}"
  proof (rule bij_betw_same_card)
    have "inj_on Rep_mod_ring {y. \<exists>x\<in>{0..<int CARD('a)}. y = Abs_mod_ring x}"
      by (meson Rep_mod_ring_inject inj_onI)
    moreover have "Rep_mod_ring ` {y. \<exists>x\<in>{0..<int CARD('a)}. (y::'a mod_ring) = Abs_mod_ring x} = {0..<int CARD('a)}"
    proof (auto simp add: image_def Rep_mod_ring_inject)
      fix xb show "0 \<le> Rep_mod_ring (Abs_mod_ring xb)"
        using Rep_mod_ring atLeastLessThan_iff by blast
      assume xb1: "0 \<le> xb" and xb2: "xb < int CARD('a)"
      thus " Rep_mod_ring (Abs_mod_ring xb) < int CARD('a)"
        by (metis Abs_mod_ring_inverse Rep_mod_ring atLeastLessThan_iff le_less_trans linear)
      have xb: "xb \<in> {0..<int CARD('a)}" using xb1 xb2 by simp
      show "\<exists>xa::'a mod_ring. (\<exists>x\<in>{0..<int CARD('a)}. xa = Abs_mod_ring x) \<and> xb = Rep_mod_ring xa"
      by (rule exI[of _ "Abs_mod_ring xb"], auto simp add: xb1 xb2, rule Abs_mod_ring_inverse[OF xb, symmetric])
    qed
    ultimately show "bij_betw Rep_mod_ring
      {y. \<exists>x\<in>{0..<int CARD('a)}. (y::'a mod_ring) = Abs_mod_ring x}
      {0..<int CARD('a)}"
      by (simp add: bij_betw_def)
  qed
  thus ?thesis
    unfolding type_definition.univ[OF type_definition_mod_ring]
    unfolding image_def by auto
qed

instance mod_ring :: (finite) finite
proof (intro_classes)
  show "finite (UNIV::'a mod_ring set)"
    unfolding type_definition.univ[OF type_definition_mod_ring]
    using finite by simp
qed

instantiation mod_ring :: (finite) equal
begin
lift_definition equal_mod_ring :: "'a mod_ring \<Rightarrow> 'a mod_ring \<Rightarrow> bool" is "(=)" .
instance by (intro_classes, transfer, auto)
end

instantiation mod_ring :: (finite) comm_ring
begin

lift_definition plus_mod_ring :: "'a mod_ring \<Rightarrow> 'a mod_ring \<Rightarrow> 'a mod_ring" is
  "\<lambda> x y. (x + y) mod int (CARD('a))" by simp

lift_definition uminus_mod_ring :: "'a mod_ring \<Rightarrow> 'a mod_ring" is
  "\<lambda> x. if x = 0 then 0 else int (CARD('a)) - x" by simp

lift_definition minus_mod_ring :: "'a mod_ring \<Rightarrow> 'a mod_ring \<Rightarrow> 'a mod_ring" is
  "\<lambda> x y. (x - y) mod int (CARD('a))" by simp

lift_definition times_mod_ring :: "'a mod_ring \<Rightarrow> 'a mod_ring \<Rightarrow> 'a mod_ring" is
  "\<lambda> x y. (x * y) mod int (CARD('a))" by simp

lift_definition zero_mod_ring :: "'a mod_ring" is 0 by simp

instance
  by standard
    (transfer; auto simp add: mod_simps algebra_simps intro: mod_diff_cong)+

end

lift_definition to_int_mod_ring :: "'a::finite mod_ring \<Rightarrow> int" is "\<lambda> x. x" .

lift_definition of_int_mod_ring :: "int \<Rightarrow> 'a::finite mod_ring" is
  "\<lambda> x. x mod int (CARD('a))" by simp

interpretation to_int_mod_ring_hom: inj_zero_hom to_int_mod_ring
  by (unfold_locales; transfer, auto)

lemma int_nat_card[simp]: "int (nat CARD('a::finite)) = CARD('a)" by auto

interpretation of_int_mod_ring_hom: zero_hom of_int_mod_ring
  by (unfold_locales, transfer, auto)

lemma of_int_mod_ring_to_int_mod_ring[simp]:
  "of_int_mod_ring (to_int_mod_ring x) = x" by (transfer, auto)

lemma to_int_mod_ring_of_int_mod_ring[simp]: "0 \<le> x \<Longrightarrow> x < int CARD('a :: finite) \<Longrightarrow>
  to_int_mod_ring (of_int_mod_ring x :: 'a mod_ring) = x"
  by (transfer, auto)

lemma range_to_int_mod_ring:
  "range (to_int_mod_ring :: ('a :: finite mod_ring \<Rightarrow> int)) = {0 ..< CARD('a)}"
  apply (intro equalityI subsetI)
  apply (elim rangeE, transfer, force)
  by (auto intro!: range_eqI to_int_mod_ring_of_int_mod_ring[symmetric])

subsection \<open>Nontrivial Finite Rings\<close>

class nontriv = assumes nontriv: "CARD('a) > 1"

subclass(in nontriv) finite by(intro_classes,insert nontriv,auto intro:card_ge_0_finite)

instantiation mod_ring :: (nontriv) comm_ring_1
begin

lift_definition one_mod_ring :: "'a mod_ring" is 1 using nontriv[where ?'a='a] by auto

instance by (intro_classes; transfer, simp)

end

interpretation to_int_mod_ring_hom: inj_one_hom to_int_mod_ring
  by (unfold_locales, transfer, simp)

lemma of_nat_of_int_mod_ring [code_unfold]:
  "of_nat = of_int_mod_ring o int"
proof (rule ext, unfold o_def)
  show "of_nat n = of_int_mod_ring (int n)" for n
  proof (induct n)
    case (Suc n)
    show ?case
      by (simp only: of_nat_Suc Suc, transfer) (simp add: mod_simps)
  qed simp
qed

lemma of_nat_card_eq_0[simp]: "(of_nat (CARD('a::nontriv)) :: 'a mod_ring) = 0"
  by (unfold of_nat_of_int_mod_ring, transfer, auto)

lemma of_int_of_int_mod_ring[code_unfold]: "of_int = of_int_mod_ring"
proof (rule ext)
  fix x :: int
  obtain n1 n2 where x: "x = int n1 - int n2" by (rule int_diff_cases)
  show "of_int x = of_int_mod_ring x"
    unfolding x of_int_diff of_int_of_nat_eq of_nat_of_int_mod_ring o_def
    by (transfer, simp add: mod_diff_right_eq mod_diff_left_eq)
qed

unbundle lifting_syntax

lemma pcr_mod_ring_to_int_mod_ring: "pcr_mod_ring = (\<lambda>x y. x = to_int_mod_ring y)"
 unfolding mod_ring.pcr_cr_eq unfolding cr_mod_ring_def to_int_mod_ring.rep_eq ..

lemma [transfer_rule]:
  "((=) ===> pcr_mod_ring) (\<lambda> x. x mod int (CARD('a :: nontriv))) (of_int :: int \<Rightarrow> 'a mod_ring)"
  by (intro rel_funI, unfold pcr_mod_ring_to_int_mod_ring of_int_of_int_mod_ring, transfer, auto)

lemma one_mod_card [simp]: "1 mod CARD('a::nontriv) = 1"
  using mod_less nontriv by blast

lemma Suc_0_mod_card [simp]: "Suc 0 mod CARD('a::nontriv) = 1"
  using one_mod_card by simp

lemma one_mod_card_int [simp]: "1 mod int CARD('a::nontriv) = 1"
proof -
  from nontriv [where ?'a = 'a] have "int (1 mod CARD('a::nontriv)) = 1"
    by simp
  then show ?thesis
    using of_nat_mod [of 1 "CARD('a)", where ?'a = int] by simp
qed

lemma pow_mod_ring_transfer[transfer_rule]:
  "(pcr_mod_ring ===> (=) ===> pcr_mod_ring)
   (\<lambda>a::int. \<lambda>n. a^n mod CARD('a::nontriv)) ((^)::'a mod_ring \<Rightarrow> nat \<Rightarrow> 'a mod_ring)"
unfolding pcr_mod_ring_to_int_mod_ring
proof (intro rel_funI,simp)
  fix x::"'a mod_ring" and n
  show "to_int_mod_ring x ^ n mod int CARD('a) = to_int_mod_ring (x ^ n)"
  proof (induct n)
    case 0
    thus ?case by auto
  next
    case (Suc n)
    have "to_int_mod_ring (x ^ Suc n) = to_int_mod_ring (x * x ^ n)" by auto
    also have "... = to_int_mod_ring x * to_int_mod_ring (x ^ n) mod CARD('a)"
      unfolding to_int_mod_ring_def using times_mod_ring.rep_eq by auto
    also have "... = to_int_mod_ring x * (to_int_mod_ring x ^ n mod CARD('a)) mod CARD('a)"
      using Suc.hyps by auto
    also have "... = to_int_mod_ring x ^ Suc n mod int CARD('a)"
      by (simp add: mod_simps)
    finally show ?case ..
  qed
qed

lemma dvd_mod_ring_transfer[transfer_rule]:
"((pcr_mod_ring :: int \<Rightarrow> 'a :: nontriv mod_ring \<Rightarrow> bool) ===>
  (pcr_mod_ring :: int \<Rightarrow> 'a mod_ring \<Rightarrow> bool) ===> (=))
  (\<lambda> i j. \<exists>k \<in> {0..<int CARD('a)}. j = i * k mod int CARD('a)) (dvd)"
proof (unfold pcr_mod_ring_to_int_mod_ring, intro rel_funI iffI)
  fix x y :: "'a mod_ring" and i j
  assume i: "i = to_int_mod_ring x" and j: "j = to_int_mod_ring y"
  { assume "x dvd y"
    then obtain z where "y = x * z" by (elim dvdE, auto)
    then have "j = i * to_int_mod_ring z mod CARD('a)" by (unfold i j, transfer)
    with range_to_int_mod_ring
    show "\<exists>k \<in> {0..<int CARD('a)}. j = i * k mod CARD('a)" by auto
  }
  assume "\<exists>k \<in> {0..<int CARD('a)}. j = i * k mod CARD('a)"
  then obtain k where k: "k \<in> {0..<int CARD('a)}" and dvd: "j = i * k mod CARD('a)" by auto
  from k have "to_int_mod_ring (of_int k :: 'a mod_ring) = k" by (transfer, auto)
  also from dvd have "j = i * ... mod CARD('a)" by auto
  finally have "y = x * (of_int k :: 'a mod_ring)" unfolding i j using k by (transfer, auto)
  then show "x dvd y" by auto
qed

lemma Rep_mod_ring_mod[simp]: "Rep_mod_ring (a :: 'a :: nontriv mod_ring) mod CARD('a) = Rep_mod_ring a"
  using Rep_mod_ring[where 'a = 'a] by auto

subsection \<open>Finite Fields\<close>

text \<open>When the domain is prime, the ring becomes a field\<close>

class prime_card = assumes prime_card: "prime (CARD('a))"
begin
lemma prime_card_int: "prime (int (CARD('a)))" using prime_card by auto

subclass nontriv using prime_card prime_gt_1_nat by (intro_classes,auto)
end

instantiation mod_ring :: (prime_card) field
begin

definition inverse_mod_ring :: "'a mod_ring \<Rightarrow> 'a mod_ring" where
  "inverse_mod_ring x = (if x = 0 then 0 else x ^ (nat (CARD('a) - 2)))"

definition divide_mod_ring :: "'a mod_ring \<Rightarrow> 'a mod_ring \<Rightarrow> 'a mod_ring"  where
  "divide_mod_ring x y = x * ((\<lambda>c. if c = 0 then 0 else c ^ (nat (CARD('a) - 2))) y)"

instance
proof
  fix a b c::"'a mod_ring"
  show "inverse 0 = (0::'a mod_ring)" by (simp add: inverse_mod_ring_def)
  show "a div b = a * inverse b"
    unfolding inverse_mod_ring_def by (transfer', simp add: divide_mod_ring_def)
  show "a \<noteq> 0 \<Longrightarrow> inverse a * a = 1"
  proof (unfold inverse_mod_ring_def, transfer)
    let ?p="CARD('a)"
    fix x
    assume x: "x \<in> {0..<int CARD('a)}" and x0: "x \<noteq> 0"
    have p0': "0\<le>?p" by auto
    have "\<not> ?p dvd x"
      using x x0 zdvd_imp_le by fastforce
    then have "\<not> CARD('a) dvd nat \<bar>x\<bar>"
      by simp
    with x have "\<not> CARD('a) dvd nat x"
      by simp
    have rw: "x ^ nat (int (?p - 2)) * x = x ^ nat (?p - 1)"
    proof -
      have p2: "0 \<le> int (?p-2)" using x by simp
      have card_rw: "(CARD('a) - Suc 0) = nat (1 + int (CARD('a) - 2))"
        using nat_eq_iff x x0 by auto
      have "x ^ nat (?p - 2)*x = x ^ (Suc (nat (?p - 2)))" by simp
      also have "... = x ^ (nat (?p - 1))"
        using Suc_nat_eq_nat_zadd1[OF p2] card_rw by auto
      finally show ?thesis .
    qed
    have "[int (nat x ^ (CARD('a) - 1)) = int 1] (mod CARD('a))"
      using fermat_theorem [OF prime_card \<open>\<not> CARD('a) dvd nat x\<close>]
      by (simp only: cong_def cong_def of_nat_mod [symmetric])
    then have *: "[x ^ (CARD('a) - 1) = 1] (mod CARD('a))"
      using x by auto
    have "x ^ (CARD('a) - 2) mod CARD('a) * x mod CARD('a)
      = (x ^ nat (CARD('a) - 2) * x) mod CARD('a)" by (simp add: mod_simps)
    also have "... =  (x ^ nat (?p - 1) mod ?p)" unfolding rw by simp
    also have "... = (x ^ (nat ?p - 1) mod ?p)" using p0' by (simp add: nat_diff_distrib')
    also have "... = 1"
      using * by (simp add: cong_def)
    finally show "(if x = 0 then 0 else x ^ nat (int (CARD('a) - 2)) mod CARD('a)) * x mod CARD('a) = 1"
      using x0 by auto
  qed
qed
end

instantiation mod_ring :: (prime_card) "{normalization_euclidean_semiring, euclidean_ring}"
begin

definition modulo_mod_ring :: "'a mod_ring \<Rightarrow> 'a mod_ring \<Rightarrow> 'a mod_ring" where "modulo_mod_ring x y = (if y = 0 then x else 0)"
definition normalize_mod_ring :: "'a mod_ring \<Rightarrow> 'a mod_ring" where "normalize_mod_ring x = (if x = 0 then 0 else 1)"
definition unit_factor_mod_ring :: "'a mod_ring \<Rightarrow> 'a mod_ring" where "unit_factor_mod_ring x = x"
definition euclidean_size_mod_ring :: "'a mod_ring \<Rightarrow> nat" where "euclidean_size_mod_ring x = (if x = 0 then 0 else 1)"

instance
proof (intro_classes)
  fix a :: "'a mod_ring" show "a \<noteq> 0 \<Longrightarrow> unit_factor a dvd 1"
    unfolding dvd_def unit_factor_mod_ring_def by (intro exI[of _ "inverse a"], auto)
qed (auto simp: normalize_mod_ring_def unit_factor_mod_ring_def modulo_mod_ring_def
     euclidean_size_mod_ring_def field_simps)
end

instantiation mod_ring :: (prime_card) euclidean_ring_gcd
begin

definition gcd_mod_ring :: "'a mod_ring \<Rightarrow> 'a mod_ring \<Rightarrow> 'a mod_ring" where "gcd_mod_ring = Euclidean_Algorithm.gcd"
definition lcm_mod_ring :: "'a mod_ring \<Rightarrow> 'a mod_ring \<Rightarrow> 'a mod_ring" where "lcm_mod_ring = Euclidean_Algorithm.lcm"
definition Gcd_mod_ring :: "'a mod_ring set \<Rightarrow> 'a mod_ring" where "Gcd_mod_ring = Euclidean_Algorithm.Gcd"
definition Lcm_mod_ring :: "'a mod_ring set \<Rightarrow> 'a mod_ring" where "Lcm_mod_ring = Euclidean_Algorithm.Lcm"

instance by (intro_classes, auto simp: gcd_mod_ring_def lcm_mod_ring_def Gcd_mod_ring_def Lcm_mod_ring_def)
end

instantiation mod_ring :: (prime_card) unique_euclidean_ring
begin

definition [simp]: "division_segment_mod_ring (x :: 'a mod_ring) = (1 :: 'a mod_ring)"

instance by intro_classes (auto simp: euclidean_size_mod_ring_def split: if_splits)

end

instance mod_ring :: (prime_card) field_gcd
  by intro_classes auto

lemma surj_of_nat_mod_ring: "\<exists> i. i < CARD('a :: prime_card) \<and> (x :: 'a mod_ring) = of_nat i"
  by (rule exI[of _ "nat (to_int_mod_ring x)"], unfold of_nat_of_int_mod_ring o_def,
  subst nat_0_le, transfer, simp, simp, transfer, auto)

lemma of_nat_0_mod_ring_dvd: assumes x: "of_nat x = (0 :: 'a ::prime_card mod_ring)"
  shows "CARD('a) dvd x"
proof -
  let ?x = "of_nat x :: int"
  from x have "of_int_mod_ring ?x = (0 :: 'a mod_ring)" by (fold of_int_of_int_mod_ring, simp)
  hence "?x mod CARD('a) = 0" by (transfer, auto)
  hence "x mod CARD('a) = 0" by presburger
  thus ?thesis unfolding mod_eq_0_iff_dvd .
qed

end