theory Pasting_Diagram
imports Strict_Omega_Category

begin

section \<open>The category of pasting diagrams\<close>

text \<open>We define the strict $\omega$-category of pasting diagrams, 'pd'. We encode its cells as rooted
 trees. First we develop some basic theory of trees.\<close>

subsection \<open>Rooted trees\<close>

datatype tree = Node (subtrees: "tree list") \<comment> \<open>\cite[p. 268]{Leinster2004}\<close>

abbreviation Leaf :: tree where
"Leaf \<equiv> Node []"

fun subtree :: "tree \<Rightarrow> nat list \<Rightarrow> tree" ("_ !t _" [59,60]59) where
"t !t [] = t" |
"t !t (i#xs) = subtrees (t !t xs) ! i"

value "Leaf !t []" (* Leaf *)
value "Node [Node [Leaf, Leaf, Leaf], Leaf, Node [Leaf]] !t [0]"    (* Node [Leaf, Leaf, Leaf] *)
value "Node [Node [Leaf, Leaf, Leaf], Leaf, Node [Leaf]] !t [2,0]"  (* Leaf *)
value "Node [Node [Leaf, Leaf, Leaf], Leaf, Node [Leaf]] !t [1]"    (* Leaf *)
value "Node [Node [Leaf, Leaf, Leaf], Leaf, Node [Leaf]] !t [0,2]"  (* Leaf *)

lemma subtrees_Leaf: "(t = Leaf) = (subtrees t = [])"
  by (metis tree.collapse tree.sel)

fun is_subtree_index :: "tree \<Rightarrow> nat list \<Rightarrow>  bool" where
"is_subtree_index t [] = True" |
"is_subtree_index t (i#xs) = (is_subtree_index t xs \<and> i < length (subtrees (t !t xs)))"

lemma subtree_append: "ts ! i !t xs = Node ts !t xs @ [i]"
  by (induction xs, auto)

lemma is_subtree_index_append [iff]: "is_subtree_index (Node ts) (xs @ [i]) =
  (i < length ts \<and> is_subtree_index (ts!i) xs)"
proof
  show "is_subtree_index (Node ts) (xs @ [i]) \<Longrightarrow> i < length ts \<and> is_subtree_index (ts ! i) xs"
  by (induction xs, auto simp: subtree_append)
next
  show "i < length ts \<and> is_subtree_index (ts ! i) xs \<Longrightarrow> is_subtree_index (Node ts) (xs @ [i])"
  by (induction xs, auto simp: subtree_append)
qed

lemma is_subtree_index_append' [iff]: "is_subtree_index t (xs @ [i]) =
  (is_subtree_index t [i] \<and> is_subtree_index (t !t [i]) xs)"
  by (metis is_subtree_index_append is_subtree_index.simps subtree.simps tree.collapse)

lemma max_set_upt [simp]: "Max {0..<Suc n} = n"
  by (simp add: Max_eq_iff)

lemma length_subtrees_eq_Max: assumes "is_subtree_index t xs" "subtrees (t !t xs) \<noteq> []"
  shows "length (subtrees (t !t xs)) = Suc (Max {i. is_subtree_index t (i # xs)})"
proof -
  have "\<And>i. is_subtree_index t (i # xs) = (i < length (subtrees (t !t xs)))" using assms(1) by simp
  hence "{i. is_subtree_index t (i # xs)} = {0..<length (subtrees (t !t xs))}" by fastforce
  moreover have "length (subtrees (t !t xs)) > 0" using assms(2) by simp
  ultimately show "length (subtrees (t !t xs)) = Suc (Max {i. is_subtree_index t (i # xs)})"
    by (metis max_set_upt gr0_implies_Suc)
qed

lemma tree_eq_iff_subtree_eq: "(t = u) = (length (subtrees t) = length (subtrees u) \<and>
  (\<forall>i < length (subtrees t). t !t [i] = u !t [i]))"
  by (cases t, cases u, auto simp add: list_eq_iff_nth_eq)

text \<open>We define the height of a rooted tree. A tree with only one node has height 0. The trees of
height at most n encode the n-cells in 'pd'.\<close>
fun height :: "tree \<Rightarrow> nat" where
"height Leaf = 0" |
"height (Node ts) = Suc (fold (max \<circ> height) ts 0)"

value "height Leaf"                              (* 0 *)
value "height (Node [Leaf, Leaf])"               (* 1 *)
value "height (Node [Node [Leaf, Leaf], Leaf])"  (* 2 *)
value "height (Node [Node [Leaf, Node [Leaf]]])" (* 3 *)

lemma height_Node [simp]: "ts \<noteq> [] \<Longrightarrow> height (Node ts) = Suc (fold (max \<circ> height) ts 0)"
  by (metis height.simps(2) neq_Nil_conv)

lemma fold_eq_Max [simp]: "ts \<noteq> [] \<Longrightarrow> fold (max \<circ> height) ts 0 = Max (set (map height ts))"
  using Max.set_eq_fold fold_map list.exhaust
  by (metis (no_types, lifting) fold_simps(2) map_is_Nil_conv max_nat.right_neutral)

lemma height_Node_Max: "ts \<noteq> [] \<Longrightarrow> height (Node ts) = Suc (Max (set (map height ts)))"
  by simp

lemma height_Node_pos : "ts \<noteq> [] \<Longrightarrow> 0 < height (Node ts)"
proof (induction "Node ts" rule: height.induct)
  case 1
  then show ?case by blast
next
  case (2 t ts')
  then show ?case by fastforce
qed

lemma height_exists:
  assumes "height (Node ts) = Suc n"
  shows "\<exists>t. t \<in> set ts \<and> height t = n"
proof (cases "ts = []")
  case True
  then show ?thesis using assms by simp
next
  case False
  hence "n = Max (set (map height ts))" using assms height_Node_Max by force
  hence "n \<in> set (map height ts)" using Max_in `ts \<noteq> []` by auto
  then show ?thesis by auto
qed

lemma height_lt: assumes "t \<in> set ts" shows "height t < height (Node ts)"
proof -
  from assms have nemp: "ts \<noteq> []" by fastforce
  have "height t \<le> Max (set (map height ts))" using assms by fastforce
  also have "\<dots> = fold (max \<circ> height) ts 0" using nemp fold_eq_Max by simp
  finally show ?thesis using nemp by simp
qed

lemma height_le_imp_le_Suc:
  assumes "\<forall>t \<in> set ts. height t \<le> n"
  shows "height (Node ts) \<le> Suc n"
proof (cases "ts = []")
  case True
  then show ?thesis by simp
next
  case False
  hence "height (Node ts) = Suc (Max (set (map height ts)))" using height_Node_Max by blast
  also have "\<dots> \<le> Suc (Max (height ` set ts))" using set_map by fastforce
  finally show ?thesis using `ts \<noteq> []` assms by simp
qed

lemma height_zero [simp]: "height t = 0 \<Longrightarrow> t = Leaf"
  by (metis height.cases height_Node_pos less_nat_zero_code)

lemma is_subtree_index_length_le: "is_subtree_index t xs \<Longrightarrow> length xs \<le> height t"
proof (induction xs arbitrary: t rule: rev_induct)
  case Nil
  then show ?case by force
next
  case (snoc i xs)
  hence hi: "i < length (subtrees t)" by (metis is_subtree_index_append tree.exhaust_sel)
  hence "length xs \<le> height (subtrees t ! i)"
    by (metis snoc is_subtree_index_append tree.exhaust_sel)
  moreover have "subtrees t ! i \<in> set (subtrees t)" using hi by simp
  ultimately show ?case using height_lt by fastforce
qed

lemma height_subtree: "is_subtree_index t xs \<Longrightarrow> height (t !t xs) \<le> height t - length xs"
proof (induction xs arbitrary: t rule: rev_induct)
  case Nil
  then show ?case by simp
next
  case (snoc i xs)
  hence "is_subtree_index (t !t [i]) xs" using is_subtree_index_append' by fastforce
  hence "height (t !t [i] !t xs) \<le> height (t !t [i]) - length xs" using snoc.IH by blast
  moreover have "height (t !t [i]) < height t"
    by (metis height_lt is_subtree_index.simps(2) is_subtree_index_append' nth_mem snoc.prems
        subtree.simps tree.collapse)
  moreover have "t !t [i] !t xs = t !t xs @ [i]" using subtree_append by simp
  ultimately show ?case by auto
qed

lemma height_induct: "(\<And>t. \<forall>u. height u < height t \<longrightarrow> P u \<Longrightarrow> P t) \<Longrightarrow> P t"
  by (metis Nat.measure_induct)

lemma subtree_index_induct [case_names Index Step]:
  assumes
    "is_subtree_index t xs"
    "\<And>xs. \<lbrakk>is_subtree_index t xs; \<forall>i < length (subtrees (t !t xs)). P (i#xs)\<rbrakk> \<Longrightarrow> P xs"
  shows "P xs"
proof -
  have hl: "length xs \<le> height t" by (simp add: assms(1) is_subtree_index_length_le)
  then show "P xs" using assms
  proof (induction "height t - length xs" arbitrary: xs)
    case 0
    hence "height (t !t xs) = 0" using height_subtree by fastforce
    hence "\<forall>i < length (subtrees (t !t xs)). P (i # xs)"
      by (metis height_zero length_0_conv less_nat_zero_code tree.sel)
    then show ?case using "0.prems" by blast
  next
    case (Suc n)
    have "\<forall>i < length (subtrees (t !t xs)). P (i # xs)"
    proof (safe)
      fix i assume "i < length (subtrees (t !t xs))"
      hence "is_subtree_index t (i # xs)" using Suc(4) by simp
      moreover hence "length (i # xs) \<le> height t" using is_subtree_index_length_le by blast
      moreover have "n = height t - length (i # xs)" using Suc(2) by simp
      ultimately show "P (i # xs)" using Suc(1) Suc(5) by blast
    qed
    then show ?case using Suc.prems by blast
  qed
qed

text \<open>The function \<open>trim\<close> keeps the first n layers of a tree and removes the remaining ones.\<close>
fun trim :: "nat \<Rightarrow> tree \<Rightarrow> tree" where
"trim 0 t = Leaf" |
"trim (Suc n) (Node ts) = Node (map (trim n) ts)"

lemma trim_Leaf [simp]: "trim n Leaf = Leaf"
  by (metis list.simps(8) trim.elims trim.simps(2))

lemma height_trim_le: "height (trim n t) \<le> n"
proof (induction n t rule: trim.induct)
  case (1 t)
  then show ?case by auto
next
  case (2 n ts)
  hence "\<forall>t' \<in> set (map (trim n) ts). height t' \<le> n" by auto
  then show ?case using height_le_imp_le_Suc trim.simps(2) by presburger
qed

lemma trim_const: "height t \<le> n \<Longrightarrow> trim n t = t"
proof (induction n t rule: trim.induct)
  case (1 t)
  then show ?case using height_zero trim_Leaf by blast
next
  case (2 n ts)
  hence "\<And>t. t \<in> set ts \<Longrightarrow> trim n t = t" using height_lt by fastforce
  hence "map (trim n) ts = ts" using map_idI by blast
  then show ?case by fastforce
qed

lemma height_trim_le': "n \<le> height t \<Longrightarrow> height (trim n t) = n"
proof (induction n t rule: trim.induct)
  case (1 t)
  then show ?case by fastforce
next
  case (2 n ts)
  hence "\<exists>m. height (Node ts) = Suc m" by presburger
  then obtain m where hm: "height (Node ts) = Suc m" by presburger
  then obtain t where ht: "t \<in> set ts \<and> height t = m" using height_exists by meson
  have "n \<le> m" using 2 hm by fastforce
  hence hn: "height (trim n t) = n" using 2 ht by blast
  have "trim n t \<in> set (subtrees (trim (Suc n) (Node ts)))" using ht by simp
  then show ?case using hn height_lt by (metis height_trim_le leD le_SucE tree.collapse)
qed

lemma height_trim: "height (trim n t) = (if n \<le> height t then n else height t)"
  using height_trim_le' trim_const by auto

value "trim 1 Leaf"
value "trim 1 (Node [Leaf, Leaf])"
value "trim 2 (Node [Node [Leaf, Leaf], Leaf])"
value "trim 1 (Node [Node [Leaf, Node [Leaf]], Node [Leaf]])"

lemma trim_trim' [simp]: "trim n \<circ> trim n = trim n"
proof (induction n)
  case 0
  then show ?case by simp
next
  case (Suc n)
  then show ?case apply (simp add: fun_eq_iff) proof
    fix t
    show "trim (Suc n) (trim (Suc n) t) = trim (Suc n) t"
      using Suc by (metis list.map_comp tree.exhaust trim.simps(2))
  qed
qed

lemma trim_trim_Suc [simp]: "trim n \<circ> trim (Suc n) = trim n"
proof (induction n)
  case 0
  then show ?case by simp
next
  case (Suc n)
  then show ?case apply (simp add: fun_eq_iff) proof
    fix t
    show "trim (Suc n) (trim (Suc (Suc n)) t) = trim (Suc n) t"
      using Suc by (metis list.map_comp tree.exhaust trim.simps(2))
  qed
qed

lemma trim_trim [simp]: "n \<le> m \<Longrightarrow> trim n \<circ> trim m = trim n"
proof (induction m arbitrary: n)
  case 0
  then show ?case by force
next
  case (Suc m)
  then show ?case proof (cases "n = Suc m")
    case True
    then show ?thesis by auto
  next
    case False
    hence "n \<le> m" using Suc.prems by auto
    hence ih: "trim n = trim n \<circ> trim m" using Suc by presburger
    hence "trim n \<circ> trim (Suc m) = (trim n \<circ> trim m) \<circ> trim (Suc m)" by simp
    also have "\<dots> = trim n \<circ> trim m" by (metis fun.map_comp trim_trim_Suc)
    finally show ?thesis using ih by auto
  qed
qed

lemma trim_eq_imp_trim_eq [simp]: "\<lbrakk>n \<le> m; trim m t = trim m u\<rbrakk> \<Longrightarrow> trim n t = trim n u"
  by (metis trim_trim comp_apply)

lemma trim_1_eq: assumes "trim 1 (Node ts) = trim 1 (Node us)" shows "length ts = length us"
proof -
  have "\<And>vs. trim 1 (Node vs) = Node (map (\<lambda>x. Leaf) vs)" by force
  then show ?thesis using assms map_eq_imp_length_eq by auto
qed

lemma length_subtrees_trim_Suc: "length (subtrees (trim (Suc n) t)) = length (subtrees t)"
  by (induction t, simp)

lemma trim_eq_Leaf: "trim n t = Leaf \<Longrightarrow> n = 0 \<or> t = Leaf"
  by (induction n t rule: trim.induct, simp_all)

lemma map_eq_imp_pairs_eq: "map f xs = map g ys \<Longrightarrow> (\<And>x y. (x, y) \<in> set (zip xs ys) \<Longrightarrow> f x = g y)"
  by (metis fst_eqD in_set_zip nth_map snd_eqD)

lemma trim_eq_subtree_eq:
  assumes "trim (Suc n) (Node ts) = trim (Suc n) (Node us)"
  shows "\<And>t u. (t, u) \<in> set (zip ts us) \<Longrightarrow> trim n t = trim n u"
proof -
  fix t u assume "(t, u) \<in> set (zip ts us)"
  moreover from assms have "map (trim n) ts = map (trim n) us" by fastforce
  ultimately show "trim n t = trim n u" using map_eq_imp_pairs_eq by fast
qed

lemma pairs_eq_imp_map_eq:
  assumes "length xs = length ys" "\<forall>(x, y) \<in> set (zip xs ys). f x = g y"
  shows "map f xs = map g ys"
proof -
  have "\<And>x y. (x, y) \<in> set (zip (map f xs) (map g ys)) \<Longrightarrow> x = y" proof -
    fix x y assume h: "(x, y) \<in> set (zip (map f xs) (map g ys))"
    hence "\<exists>n. (map f xs)!n = x \<and> (map g ys)!n = y \<and> n < length xs \<and> n < length ys"
      by (metis in_set_zip fst_conv length_map snd_conv)
    then obtain n where hn: "(map f xs)!n = x" "(map g ys)!n = y" "n < length xs" "n < length ys"
      by blast
    hence "(xs!n, ys!n) \<in> set (zip xs ys)" using in_set_zip by fastforce
    with hn assms(2) show "x = y" by auto
  qed
  hence "\<forall>(x, y) \<in> set (zip (map f xs) (map g ys)). x = y" by force
  with assms(1) list_eq_iff_zip_eq show "map f xs = map g ys" by fastforce
qed

lemma map_eq_iff_pairs_eq: "(map f xs = map g ys) =
  (length xs = length ys \<and> (\<forall>(x, y) \<in> set (zip xs ys). f x = g y))"
proof -
  have "map f xs = map g ys \<Longrightarrow> \<forall>(x, y) \<in> set (zip xs ys). f x = g y" using map_eq_imp_pairs_eq
    by fast
  thus ?thesis by (metis pairs_eq_imp_map_eq length_map)
qed

lemma subtree_eq_trim_eq:
  assumes "length ts = length us" "\<forall>(t, u) \<in> set (zip ts us). trim n t = trim n u"
  shows "trim (Suc n) (Node ts) = trim (Suc n) (Node us)"
  by (auto simp add: assms map_eq_iff_pairs_eq)

lemma subtree_trim_1: "is_subtree_index t [i] \<Longrightarrow> trim (Suc n) t !t [i] = trim n (t !t [i])"
  by (smt (verit) Suc_inject is_subtree_index.simps(2) list.distinct(1) nat.distinct(1) nth_map
      subtree.elims subtree.simps(2) tree.sel trim.elims)

lemma is_subtree_index_trim:
  "is_subtree_index (trim n t) xs = (is_subtree_index t xs \<and> length xs \<le> n)"
proof (induction n t arbitrary: xs rule: trim.induct)
  case (1 t)
  then show ?case using is_subtree_index_length_le by fastforce
next
  case (2 n ts)
  then show ?case proof (induction xs rule: rev_induct)
    case Nil
    then show ?case by auto
  next
    case (snoc x xs)
    then show ?case by fastforce
  qed
qed

lemma subtree_trim: "\<lbrakk>is_subtree_index t xs; length xs \<le> n\<rbrakk> \<Longrightarrow>
  trim n t !t xs = trim (n - length xs) (t !t xs)"
proof (induction n t arbitrary: xs rule: trim.induct)
  case (1 t)
  then show ?case by simp
next
  case (2 n ts)
  then show ?case proof (cases "length xs = Suc n")
    case True
    hence "is_subtree_index (trim (Suc n) (Node ts)) xs" using is_subtree_index_trim 2 by blast
    hence "height (trim (Suc n) (Node ts) !t xs) \<le> 0"
      by (metis height_subtree height_trim_le True diff_is_0_eq')
    then show ?thesis using True height_zero by fastforce
  next
    case False
    then show ?thesis proof (cases xs rule: rev_cases)
      case Nil
      then show ?thesis by simp
    next
      case (snoc ys i)
      have hi: "ts ! i \<in> set ts" "is_subtree_index (ts ! i) ys" using snoc 2(2) by simp_all
      have hl: "length ys \<le> n" using snoc 2(3) by simp
      have "Node (map (trim n) ts) !t ys @ [i] = trim n (ts ! i) !t ys"
        by (metis "2.prems"(1) is_subtree_index_append nth_map snoc subtree_append)
      also have "\<dots> = trim (n - length ys) (ts ! i !t ys)" using 2(1) hi hl by blast
      finally show "trim (Suc n) (Node ts) !t xs = trim (Suc n - length xs) (Node ts !t xs)"
        by (simp add: snoc subtree_append)
    qed
  qed
qed

lemma length_subtrees_trim: "\<lbrakk>is_subtree_index t xs; length xs < n\<rbrakk> \<Longrightarrow>
  length (subtrees (trim n t !t xs)) = length (subtrees (t !t xs))"
  by (metis subtree_trim length_subtrees_trim_Suc Suc_diff_Suc less_imp_le_nat)

lemma subtree_trim_Leaf: assumes "is_subtree_index (trim n t) xs" "t !t xs = Leaf"
  shows "trim n t !t xs = Leaf"
proof (cases "length xs < n")
  case True
  then show ?thesis
    using length_subtrees_trim assms is_subtree_index_trim subtrees_Leaf by fastforce
next
  case False
  hence "length xs = n" using assms(1) by (simp add: is_subtree_index_trim)
  then show ?thesis using assms(1) is_subtree_index_trim subtree_trim by auto
qed

subsection \<open>The strict $\omega$-category of pasting diagrams\<close>

text \<open>The function \<open>\<delta>\<close> acts as both the source and target map in the globular set of pasting
diagrams. It is denoted $\partial$ in Leinster \cite[p. 264]{Leinster2004}.\<close>
abbreviation \<delta> where
"\<delta> \<equiv> trim"

value "\<delta> 1 (Node [Node [Leaf, Leaf, Leaf], Leaf, Node [Leaf]])"  (* Leinster2004: (8.1), p. 264 *)
value "\<delta> 2 (Node [Node [Node [Leaf, Leaf]], Node [Leaf, Leaf]])" (* Leinster2004: (8.3), p. 265 *)

abbreviation PD :: "nat \<Rightarrow> tree set" where
"PD n \<equiv> {t. height t \<le> n}"

interpretation pd: globular_set PD \<delta> \<delta>
  by (unfold_locales, auto simp add: height_trim_le)

text \<open>The generalised source and target maps have simple interpretations in terms of \<open>trim\<close>.\<close>

lemma s'_eq_trim: assumes "n \<le> m" "height t \<le> m" shows "pd.s' m n t = trim n t"
  using assms
proof (induction m arbitrary: t)
  case 0
  moreover hence "n = 0" by force
  ultimately show ?case using pd.s'_n_n trim_const by simp
next
  case (Suc m)
  then show ?case proof (cases "n = Suc m")
    case True
    then show ?thesis using pd.s'_n_n Suc(3) trim_const by simp
  next
    case False
    with Suc(2) have "n \<le> m" by simp
    hence "pd.s' (Suc m) n t = pd.s' m n (\<delta> m t)" using Suc(3) by force
    also have "\<dots> = \<delta> n (\<delta> m t)" using Suc.IH height_trim_le \<open>n \<le> m\<close> by blast
    finally show ?thesis by (metis trim_trim \<open>n \<le> m\<close> comp_apply)
  qed
qed

lemma s'_eq_t': "pd.s' = pd.t'"
proof (clarsimp simp add: fun_eq_iff)
  fix m n t
  show "pd.s' m n t = pd.t' m n t" proof (induction m arbitrary: n t)
    case 0
    then show ?case
      using pd.s'_n_n pd.t'_n_n pd.s'.simps(2) pd.t'.simps(2) by (cases n, presburger+)
  next
    case (Suc m)
    then show ?case by (cases "Suc m" rule: linorder_cases, simp_all)
  qed
qed

lemma t'_eq_trim: assumes "n \<le> m" "height t \<le> m" shows "pd.t' m n t = trim n t"
  by (metis (mono_tags, lifting) assms s'_eq_trim s'_eq_t')

text \<open>Next we define identities and composition \cite[p. 266]{Leinster2004}. The identity of a tree with height at most \<open>n\<close> is
  the same tree seen as a tree of height at most \<open>n + 1\<close>.\<close>

fun tree_comp :: "nat \<Rightarrow> tree \<Rightarrow> tree \<Rightarrow> tree" where
"tree_comp 0 (Node ts) (Node us) = Node (ts @ us)" |
"tree_comp (Suc n) (Node ts) (Node us) = Node (map2 (tree_comp n) ts us)"

value "tree_comp 1
  (Node [Node [Leaf, Leaf], Leaf, Node [Leaf]])
  (Node [Leaf, Leaf, Node [Leaf, Leaf]])"
  (* Node [Node [Leaf, Leaf], Leaf, Node [Leaf, Leaf, Leaf]] *)
  (* Leinster2001: p. 39 *)

value "tree_comp 0
  (Node [Node [Node [Leaf, Leaf]]])
  (Node [Node [Leaf, Leaf]])"
  (* Node [Node [Node [Leaf, Leaf]], Node [Leaf, Leaf]] *)
  (* Leinster2001: p. 39 *)

value "tree_comp 0
  (tree_comp 0
    (tree_comp 1
      (Node [Leaf, Leaf])
      (Node [Node [Leaf], Node [Leaf, Leaf, Leaf]]))
    (Node [Leaf, Node [Leaf, Leaf]]))
  (Node [Leaf, Leaf, Leaf])"
  (* Node [
      Node [Leaf],
      Node [Leaf, Leaf, Leaf],
      Leaf,
      Node [Leaf, Leaf],
      Leaf,
      Leaf,
      Leaf]*)
  (* Leinster2001: p. 40 *)

lemma tree_comp_0_Leaf1 [simp]: "tree_comp 0 Leaf t = t"
  by (metis eq_Nil_appendI tree.exhaust tree_comp.simps(1))

lemma tree_comp_0_Leaf2 [simp]: "tree_comp 0 t Leaf = t"
  by (metis append_Nil2 tree.exhaust tree_comp.simps(1))

lemma tree_comp_Suc_Leaf1 [simp]: "tree_comp (Suc n) Leaf t = Leaf"
  by (cases t, simp)

lemma tree_comp_Suc_Leaf2 [simp]: "tree_comp (Suc n) t Leaf = Leaf"
  by (cases t, simp)

lemma height_tree_comp_0 [simp]: "height (tree_comp 0 t u) = max (height t) (height u)"
proof (cases "t = Leaf \<or> u = Leaf")
  case True
  then show ?thesis by auto
next
  case False
  hence nempt: "subtrees t \<noteq> [] \<and> subtrees u \<noteq> []" by (metis tree.exhaust_sel)
  have "height (tree_comp 0 t u) = height (Node (subtrees t @ subtrees u))"
    by (metis tree.collapse tree_comp.simps(1))
  also have "\<dots> = Suc (Max (set (map height (subtrees t @ subtrees u))))"
    using nempt height_Node_Max by blast
  also have "\<dots> = Suc (Max (set (map height (subtrees t)) \<union> set (map height (subtrees u))))"
    by simp
  also have "\<dots> = Suc (max (Max (set (map height (subtrees t))))
                          (Max (set (map height (subtrees u)))))"
    using nempt Max_Un by (metis List.finite_set map_is_Nil_conv set_empty2)
  also have "\<dots> = max (Suc (Max (set (map height (subtrees t)))))
                         (Suc (Max (set (map height (subtrees u)))))"
    by linarith
  finally show "height (tree_comp 0 t u) = max (height t) (height u)"
    using nempt height_Node_Max by (metis tree.collapse)
qed

text \<open>An alternative description of being composable for trees. Defined so that
\<open>tree_comp n t u\<close> is defined if and only if \<open>composable_tree n t u\<close>.\<close>
fun composable_tree :: "nat \<Rightarrow> tree \<Rightarrow> tree \<Rightarrow> bool" where
"composable_tree 0 (Node ts) (Node us) = True" |
"composable_tree (Suc n) (Node ts) (Node us) = (length ts = length us \<and>
  (\<forall>i < length ts. composable_tree n (ts!i) (us!i)))"

lemma sym_composable_tree: "composable_tree n t u = composable_tree n u t"
  by (induction n t u rule: composable_tree.induct, simp, fastforce)

lemma is_composable_pair_imp_composable_tree: "pd.is_composable_pair m n t u \<Longrightarrow>
  composable_tree n t u"
proof (induction n t u rule: composable_tree.induct)
  case (1 ts us)
  then show ?case by fastforce
next
  case (2 n ts us)
  with pd.is_composable_pair_def have h: "Suc n < m" "height (Node ts) \<le> m" "height (Node us) \<le> m"
    "pd.t' m (Suc n) (Node us) = pd.s' m (Suc n) (Node ts)" by blast+
  moreover hence "Suc n \<le> m" by linarith
  ultimately have htrim: "trim (Suc n) (Node ts) = trim (Suc n) (Node us)"
    by (metis (mono_tags, lifting) s'_eq_trim t'_eq_trim)
  hence "trim 1 (Node ts) = trim 1 (Node us)"
    by (metis One_nat_def Suc_le_mono le0 trim_eq_imp_trim_eq)
  with trim_1_eq have hl: "length ts = length us" by blast
  moreover have "\<forall>i < length ts. composable_tree n (ts!i) (us!i)" proof (safe)
    fix i assume hi: "i < length ts"
    hence "height (ts!i) \<le> m" using h(2) height_lt nth_mem by fastforce
    moreover have "height (us!i) \<le> m" using hi h(3) height_lt nth_mem hl by fastforce
    moreover have "n < m" using h(1) by simp
    moreover have "trim n (ts!i) = trim n (us!i)" proof -
      have "map (trim n) ts = map (trim n) us" using htrim by auto
      thus "trim n (ts!i) = trim n (us!i)" using nth_map hi hl by metis
    qed
    ultimately have "pd.t' m n (us!i) = pd.s' m n (ts!i)"
      using s'_eq_trim t'_eq_trim order_less_imp_le[of n m] by presburger
    hence "pd.is_composable_pair m n (ts!i) (us!i)"
      using pd.is_composable_pair_def \<open>n < m\<close> \<open>height (ts!i) \<le> m\<close> \<open>height (us!i) \<le> m\<close> by blast
    with 2(1) hi show "composable_tree n (ts!i) (us!i)" by fast
  qed
  ultimately show ?case by fastforce
qed

lemma composable_tree_imp_trim_eq: "composable_tree n t u \<Longrightarrow> trim n t = trim n u"
proof (induction n t u rule: composable_tree.induct)
  case (1 ts us)
  then show ?case by simp
next
  case (2 n ts us)
  then show ?case
    by (metis (mono_tags, lifting) nth_map trim.simps(2) length_map nth_equalityI
        composable_tree.simps(2))
qed

lemma composable_tree_imp_is_composable_pair:
  assumes "n < m" "height t \<le> m" "height u \<le> m" "composable_tree n t u"
  shows "pd.is_composable_pair m n t u"
  using assms
proof (induction m arbitrary: n t u)
  case 0
  then show ?case by blast
next
  case (Suc m)
  hence "trim n u = trim n t" using composable_tree_imp_trim_eq by presburger
  hence "pd.t' (Suc m) n u = pd.s' (Suc m) n t"
    using Suc(2-4) s'_eq_trim t'_eq_trim less_imp_le_nat by presburger
  with Suc(2-4) pd.is_composable_pair_def show ?case by blast
qed

lemma is_composable_pair_iff_composable_tree: "pd.is_composable_pair m n t u =
  (n < m \<and> height t \<le> m \<and> height u \<le> m \<and> composable_tree n t u)"
  by (metis (mono_tags, lifting) composable_tree_imp_is_composable_pair
      is_composable_pair_imp_composable_tree mem_Collect_eq pd.is_composable_pair_def)

lemma composable_tree_imp_composable_tree_subtrees:
  "composable_tree (Suc n) (Node ts) (Node us) \<Longrightarrow> \<forall>(t, u) \<in> set (zip ts us). composable_tree n t u"
  by (metis in_set_zip case_prod_beta composable_tree.simps(2))

lemma composable_tree_nth_subtrees:
  "\<lbrakk>composable_tree (Suc n) (Node ts) (Node us); i < length ts\<rbrakk> \<Longrightarrow> composable_tree n (ts!i) (us!i)"
  by fastforce

lemma is_composable_pair_imp_is_composable_pair_subtrees:
  assumes "pd.is_composable_pair (Suc m) (Suc n) (Node ts) (Node us)"
  shows "\<forall>(t, u) \<in> set (zip ts us). pd.is_composable_pair m n t u"
proof
  have "pd.is_composable_pair m n (fst p) (snd p)" if hp: "p \<in> set (zip ts us)" for p proof -
    have "composable_tree (Suc n) (Node ts) (Node us)"
      using is_composable_pair_iff_composable_tree assms by blast
    hence h: "composable_tree n (fst p) (snd p)"
      using hp composable_tree_imp_composable_tree_subtrees by fastforce
    have "fst p \<in> set ts" "snd p \<in> set us" by (metis hp in_set_zipE prod.exhaust_sel)+
    hence "height (fst p) \<le> m" "height (snd p) \<le> m"
      by (meson hp height_lt assms less_Suc_eq_le order_less_le_trans
          is_composable_pair_iff_composable_tree)+
    with h is_composable_pair_iff_composable_tree assms
    show "pd.is_composable_pair m n (fst p) (snd p)" by force
  qed
  then show "\<And>x. x \<in> set (zip ts us) \<Longrightarrow> case x of (t, u) \<Rightarrow> pd.is_composable_pair m n t u"
    by force
qed

lemma in_set_map2: "(z \<in> set (map2 f xs ys)) = (\<exists>(x, y) \<in> set (zip xs ys). z = f x y)"
  by auto

lemma height_tree_comp_le: "\<lbrakk>height t \<le> m; height u \<le> m\<rbrakk> \<Longrightarrow> height (tree_comp n t u) \<le> m"
proof (induction n t u arbitrary: m rule: tree_comp.induct)
  case (1 ts us)
  then show ?case using height_tree_comp_0 by presburger
next
  case (2 n ts us)
  show ?case proof (cases "ts \<noteq> [] \<and> us \<noteq> []")
    case True
    hence "\<exists>m'. m = Suc m'" using height_zero "2.prems"(1) not0_implies_Suc by auto
    then obtain m' where "m = Suc m'" by blast
    hence "\<forall>t \<in> set ts. height t \<le> m'" "\<forall>u \<in> set us. height u \<le> m'"
      using True "2.prems" by simp+
    hence "\<forall>(t, u) \<in> set (zip ts us). height (tree_comp n t u) \<le> m'"
      by (metis (no_types, lifting) "2.IH" case_prodI2 set_zip_leftD set_zip_rightD)
    then show ?thesis using True \<open>m = Suc m'\<close> by auto
  next
    case False
    then show ?thesis by force
  qed
qed

lemma nth_map2 [simp]: "\<lbrakk>n < length xs; n < length ys\<rbrakk> \<Longrightarrow> map2 f xs ys ! n = f (xs ! n) (ys ! n)"
  by fastforce

lemma trim_tree_comp1: "composable_tree n t u \<Longrightarrow> trim n (tree_comp n t u) = trim n t"
proof (induction n t u rule: composable_tree.induct)
  case (1 ts us)
  then show ?case by fastforce
next
  case (2 n ts us)
  then show ?case by (simp add: list_eq_iff_nth_eq)
qed

lemma trim_tree_comp2: "composable_tree n t u \<Longrightarrow> trim n (tree_comp n t u) = trim n u"
  using trim_tree_comp1 composable_tree_imp_trim_eq by presburger

lemma map2_map_map': "map2 f (map g xs) (map h ys) = map (\<lambda>(x, y). f (g x) (h y)) (zip xs ys)"
proof (induction xs arbitrary: ys)
  case Nil
  then show ?case by simp
next
  case (Cons a xs)
  then show ?case proof (induction ys)
    case Nil
    then show ?case by simp
  next
    case (Cons a ys)
    then show ?case by auto
  qed
qed

lemma trim_tree_comp_commute: "trim m (tree_comp n t u) = tree_comp n (trim m t) (trim m u)"
proof (induction m arbitrary: n t u)
  case 0
  then show ?case by (cases n, simp_all)
next
  case (Suc m)
  then show ?case
    by (induction n t u rule: composable_tree.induct, simp_all add: list_eq_iff_nth_eq)
qed

interpretation pd_pre_cat: pre_strict_omega_category PD \<delta> \<delta> "\<lambda> m. tree_comp" "\<lambda> n. id"
proof (unfold_locales)
  fix m n x' x assume "pd.is_composable_pair m n x' x"
  then show "tree_comp n x' x \<in> PD m"
    using is_composable_pair_iff_composable_tree height_tree_comp_le by auto
next
  fix n show "id \<in> PD n \<rightarrow> PD (Suc n)" by simp
next
  fix m x' x assume "pd.is_composable_pair (Suc m) m x' x"
  then show "\<delta> m (tree_comp m x' x) = \<delta> m x"
    by (simp add: is_composable_pair_iff_composable_tree trim_tree_comp2 height_tree_comp_le)
next
  fix m x' x assume "pd.is_composable_pair (Suc m) m x' x"
  then show "\<delta> m (tree_comp m x' x) = \<delta> m x'"
    by (simp add: is_composable_pair_iff_composable_tree trim_tree_comp1 height_tree_comp_le)
next
  fix m n x' x assume "pd.is_composable_pair (Suc m) n x' x" "n < m"
  then show "\<delta> m (tree_comp n x' x) = tree_comp n (\<delta> m x') (\<delta> m x)"
    by (simp add: is_composable_pair_iff_composable_tree trim_tree_comp_commute height_tree_comp_le)
next
  fix x n assume "x \<in> PD n"
  then show "\<delta> n (id x) = x" using trim_const by auto
qed

lemma tree_comp_assoc: "tree_comp n (tree_comp n t u) v = tree_comp n t (tree_comp n u v)"
proof (induction n t u arbitrary: v rule: composable_tree.induct)
  case (1 ts us)
  then show ?case by (metis append_assoc tree_comp.simps(1) tree.exhaust)
next
  case (2 n ts us)
  define vs where "vs = subtrees v" hence hv: "v = Node vs" by force
  let ?k = "min (length ts) (min (length us) (length vs))"
  have "\<forall>i < ?k. tree_comp n (tree_comp n (ts!i) (us!i)) (vs!i) =
    tree_comp n (ts!i) (tree_comp n (us!i) (vs!i))" using "2.IH" by auto
  hence "map2 (tree_comp n) (map2 (tree_comp n) ts us) vs =
    map2 (tree_comp n) ts (map2 (tree_comp n) us vs)" by (simp add: list_eq_iff_nth_eq)
  then show ?case using hv by auto
qed

lemma i'_eq_id: "n \<le> m \<Longrightarrow> pd_pre_cat.i' m n = id"
proof (induction m)
  case 0
  then show ?case using pd_pre_cat.i'.simps(1) by blast
next
  case (Suc m)
  then show ?case by (metis pd_pre_cat.i'_Suc id_comp le_Suc_eq pd_pre_cat.i'_n_n)
qed

lemma composable_tree_trim1: "n \<le> m \<Longrightarrow> composable_tree n (trim m t) t"
proof (induction n t arbitrary: m rule: trim.induct)
  case (1 t)
  then show ?case by (metis composable_tree.simps(1) tree.exhaust)
next
  case (2 n ts)
  hence "\<exists>m'. m = Suc m'" by presburger
  then obtain m' where hm: "m = Suc m'" "n \<le> m'" using 2(2) by blast
  moreover hence "\<forall>i < length ts. composable_tree n (\<delta> m' (ts!i)) (ts!i)" using 2(1) by simp
  ultimately show ?case by force
qed

lemma composable_tree_trim2: "n \<le> m \<Longrightarrow> composable_tree n t (trim m t)"
  using sym_composable_tree composable_tree_trim1 by presburger

lemma tree_comp_trim1: "tree_comp n (trim n t) t = t"
  by (induction n t rule: trim.induct, simp add: tree.exhaust, simp add: list_eq_iff_nth_eq)

lemma tree_comp_trim2: "tree_comp n t (trim n t) = t"
  by (induction n t rule: trim.induct, simp add: tree.exhaust, simp add: list_eq_iff_nth_eq)

lemma tree_comp_exchange:
  "\<lbrakk>q < p; composable_tree p y' y; composable_tree p x' x;
  composable_tree q y' x'; composable_tree q y x\<rbrakk> \<Longrightarrow>
  tree_comp q (tree_comp p y' y) (tree_comp p x' x) =
  tree_comp p (tree_comp q y' x') (tree_comp q y x)"
proof (induction p y' y arbitrary: q x' x rule: composable_tree.induct)
  case (1 ys' ys)
  then show ?case proof (induction q x' x rule: composable_tree.induct)
    case (1 xs' xs)
    then show ?case by blast
  next
    case (2 q xs' xs)
    then show ?case by force
  qed
next
  case (2 p ys' ys)
  then show ?case proof (induction q x' x rule: composable_tree.induct)
    case (1 ts us)
    then show ?case by force
  next
    case (2 n ts us)
    then show ?case by (simp add: list_eq_iff_nth_eq)
  qed
qed

interpretation pd_cat': strict_omega_category PD \<delta> \<delta> "\<lambda> m. tree_comp" "\<lambda> n. id"
proof (unfold_locales)
  fix m n x' x x'' assume "pd.is_composable_pair m n x' x" "pd.is_composable_pair m n x'' x'"
  then show "tree_comp n (tree_comp n x'' x') x = tree_comp n x'' (tree_comp n x' x)"
    using tree_comp_assoc is_composable_pair_iff_composable_tree by force
next
  fix n m x assume "n < m" "x \<in> PD m"
  moreover hence "height x \<le> m" by simp
  ultimately show "tree_comp n (pd_pre_cat.i' m n (pd.t' m n x)) x = x"
    by (metis (no_types, lifting) i'_eq_id t'_eq_trim tree_comp_trim1 id_apply nat_less_le)
next
  fix n m x assume "n < m" "x \<in> PD m"
  moreover hence "height x \<le> m" by simp
  ultimately show "tree_comp n x (pd_pre_cat.i' m n (pd.s' m n x)) = x"
    by (metis (no_types, lifting) i'_eq_id s'_eq_trim tree_comp_trim2 id_apply nat_less_le)
next
  fix q p m y' y x' x assume "q < p" "p < m"
    "pd.is_composable_pair m p y' y" "pd.is_composable_pair m p x' x"
    "pd.is_composable_pair m q y' x'" "pd.is_composable_pair m q y x"
  then show "tree_comp q (tree_comp p y' y) (tree_comp p x' x) =
    tree_comp p (tree_comp q y' x') (tree_comp q y x)"
    using is_composable_pair_iff_composable_tree tree_comp_exchange by meson
qed (simp)

end


(*  Title:       Relational Chains over Lazy Lists
    Author:      Jasmin Blanchette <j.c.blanchette at vu.nl>, 2014, 2017
    Author:      Dmitriy Traytel <traytel at inf.ethz.ch>, 2017
    Author:      Anders Schlichtkrull <andschl at dtu.dk>, 2017
    Maintainer:  Anders Schlichtkrull <andschl at dtu.dk>
*)

section \<open>Relational Chains over Lazy Lists\<close>

theory Lazy_List_Chain
  imports
    "HOL-Library.BNF_Corec"
    Lazy_List_Liminf
begin

text \<open>
A chain is a lazy list of elements such that all pairs of consecutive elements are related by a
given relation. A full chain is either an infinite chain or a finite chain that cannot be extended.
The inspiration for this theory is Section 4.1 (``Theorem Proving Processes'') of Bachmair and
Ganzinger's chapter.
\<close>

subsection \<open>Chains\<close>

coinductive chain :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a llist \<Rightarrow> bool" for R :: "'a \<Rightarrow> 'a \<Rightarrow> bool" where
  chain_singleton: "chain R (LCons x LNil)"
| chain_cons: "chain R xs \<Longrightarrow> R x (lhd xs) \<Longrightarrow> chain R (LCons x xs)"

lemma
  chain_LNil[simp]: "\<not> chain R LNil" and
  chain_not_lnull: "chain R xs \<Longrightarrow> \<not> lnull xs"
  by (auto elim: chain.cases)

lemma chain_lappend:
  assumes
    r_xs: "chain R xs" and
    r_ys: "chain R ys" and
    mid: "R (llast xs) (lhd ys)"
  shows "chain R (lappend xs ys)"
proof (cases "lfinite xs")
  case True
  then show ?thesis
    using r_xs mid
  proof (induct rule: lfinite.induct)
    case (lfinite_LConsI xs x)
    note fin = this(1) and ih = this(2) and r_xxs = this(3) and mid = this(4)
    show ?case
    proof (cases "xs = LNil")
      case True
      then show ?thesis
        using r_ys mid by simp (rule chain_cons)
    next
      case xs_nnil: False
      have r_xs: "chain R xs"
        by (metis chain.simps ltl_simps(2) r_xxs xs_nnil)
      have mid': "R (llast xs) (lhd ys)"
        by (metis llast_LCons lnull_def mid xs_nnil)
      have start: "R x (lhd (lappend xs ys))"
        by (metis (no_types) chain.simps lhd_LCons lhd_lappend chain_not_lnull ltl_simps(2) r_xxs
            xs_nnil)
      show ?thesis
        unfolding lappend_code(2) using ih[OF r_xs mid'] start by (rule chain_cons)
    qed
  qed simp
qed (simp add: r_xs lappend_inf)

lemma chain_length_pos: "chain R xs \<Longrightarrow> llength xs > 0"
  by (cases xs) simp+

lemma chain_ldropn:
  assumes "chain R xs" and "enat n < llength xs"
  shows "chain R (ldropn n xs)"
  using assms
  by (induct n arbitrary: xs, simp,
      metis chain.cases ldrop_eSuc_ltl ldropn_LNil ldropn_eq_LNil ltl_simps(2) not_less)

lemma inf_chain_ldropn_chain: "chain R xs \<Longrightarrow> \<not> lfinite xs \<Longrightarrow> chain R (ldropn n xs)"
  using chain.simps[of R xs] by (simp add: chain_ldropn not_lfinite_llength)

lemma inf_chain_ltl_chain: "chain R xs \<Longrightarrow> \<not> lfinite xs \<Longrightarrow> chain R (ltl xs)"
  by (metis inf_chain_ldropn_chain ldropn_0 ldropn_ltl)

lemma chain_lnth_rel:
  assumes
    chain: "chain R xs" and
    len: "enat (Suc j) < llength xs"
  shows "R (lnth xs j) (lnth xs (Suc j))"
proof -
  define ys where "ys = ldropn j xs"
  have "llength ys > 1"
    unfolding ys_def using len
    by (metis One_nat_def funpow_swap1 ldropn_0 ldropn_def ldropn_eq_LNil ldropn_ltl not_less
        one_enat_def)
  obtain y0 y1 ys' where
    ys: "ys = LCons y0 (LCons y1 ys')"
    unfolding ys_def by (metis Suc_ile_eq ldropn_Suc_conv_ldropn len less_imp_not_less not_less)
  have "chain R ys"
    unfolding ys_def using Suc_ile_eq chain chain_ldropn len less_imp_le by blast
  then have "R y0 y1"
    unfolding ys by (auto elim: chain.cases)
  then show ?thesis
    using ys_def unfolding ys by (metis ldropn_Suc_conv_ldropn ldropn_eq_LConsD llist.inject)
qed

lemma infinite_chain_lnth_rel:
  assumes "\<not> lfinite c" and "chain r c"
  shows "r (lnth c i) (lnth c (Suc i))"
  using assms chain_lnth_rel lfinite_conv_llength_enat by force

lemma lnth_rel_chain:
  assumes
    "\<not> lnull xs" and
    "\<forall>j. enat (j + 1) < llength xs \<longrightarrow> R (lnth xs j) (lnth xs (j + 1))"
  shows "chain R xs"
  using assms
proof (coinduction arbitrary: xs rule: chain.coinduct)
  case chain
  note nnul = this(1) and nth_chain = this(2)

  show ?case
  proof (cases "lnull (ltl xs)")
    case True
    have "xs = LCons (lhd xs) LNil"
      using nnul True by (simp add: llist.expand)
    then show ?thesis
      by blast
  next
    case nnul': False
    moreover have "xs = LCons (lhd xs) (ltl xs)"
      using nnul by simp
    moreover have
      "\<forall>j. enat (j + 1) < llength (ltl xs) \<longrightarrow> R (lnth (ltl xs) j) (lnth (ltl xs) (j + 1))"
      using nnul nth_chain
      by (metis Suc_eq_plus1 ldrop_eSuc_ltl ldropn_Suc_conv_ldropn ldropn_eq_LConsD lnth_ltl)
    moreover have "R (lhd xs) (lhd (ltl xs))"
      using nnul' nnul nth_chain[rule_format, of 0, simplified]
      by (metis ldropn_0 ldropn_Suc_conv_ldropn ldropn_eq_LConsD lhd_LCons_ltl lhd_conv_lnth
          lnth_Suc_LCons ltl_simps(2))
    ultimately show ?thesis
      by blast
  qed
qed

lemma chain_lmap:
  assumes "\<forall>x y. R x y \<longrightarrow> R' (f x) (f y)" and "chain R xs"
  shows "chain R' (lmap f xs)"
  using assms
proof (coinduction arbitrary: xs)
  case chain
  then have "(\<exists>y. xs = LCons y LNil) \<or> (\<exists>ys x. xs = LCons x ys \<and> chain R ys \<and> R x (lhd ys))"
    using chain.simps[of R xs] by auto
  then show ?case
  proof
    assume "\<exists>ys x. xs = LCons x ys \<and> chain R ys \<and> R x (lhd ys)"
    then have "\<exists>ys x. lmap f xs = LCons x ys \<and>
      (\<exists>xs. ys = lmap f xs \<and> (\<forall>x y. R x y \<longrightarrow> R' (f x) (f y)) \<and> chain R xs) \<and> R' x (lhd ys)"
      using chain
      by (metis (no_types) lhd_LCons llist.distinct(1) llist.exhaust_sel llist.map_sel(1)
          lmap_eq_LNil chain_not_lnull ltl_lmap ltl_simps(2))
    then show ?thesis
      by auto
  qed auto
qed

lemma chain_mono:
  assumes "\<forall>x y. R x y \<longrightarrow> R' x y" and "chain R xs"
  shows "chain R' xs"
  using assms by (rule chain_lmap[of _ _ "\<lambda>x. x", unfolded llist.map_ident])

lemma chain_ldropnI:
  assumes
    rel: "\<forall>j. j \<ge> i \<longrightarrow> enat (Suc j) < llength xs \<longrightarrow> R (lnth xs j) (lnth xs (Suc j))" and
    si_lt: "enat (Suc i) < llength xs"
  shows "chain R (ldropn i xs)"
proof (rule lnth_rel_chain)
  show "\<not> lnull (ldropn i xs)"
    using si_lt by (simp add: Suc_ile_eq less_le_not_le)
next
  show "\<forall>j. enat (j + 1) < llength (ldropn i xs) \<longrightarrow>
    R (lnth (ldropn i xs) j) (lnth (ldropn i xs) (j + 1))"
    using rel by (smt (z3) One_nat_def Suc_ile_eq add.commute add.right_neutral add_Suc_right
        add_le_cancel_right ldropn_eq_LNil ldropn_ldropn less_le_not_le linorder_not_less
        lnth_ldropn not_less_zero)
qed

lemma chain_ldropn_lmapI:
  assumes
    rel: "\<forall>j. j \<ge> i \<longrightarrow> enat (Suc j) < llength xs \<longrightarrow> R (f (lnth xs j)) (f (lnth xs (Suc j)))" and
    si_lt: "enat (Suc i) < llength xs"
  shows "chain R (ldropn i (lmap f xs))"
proof -
  have "chain R (lmap f (ldropn i xs))"
    using chain_lmap[of "\<lambda>x y. R (f x) (f y)" R f, of "ldropn i xs"] chain_ldropnI[OF rel si_lt]
    by auto
  thus ?thesis
    by auto
qed

lemma lfinite_chain_imp_rtranclp_lhd_llast: "lfinite xs \<Longrightarrow> chain R xs \<Longrightarrow> R\<^sup>*\<^sup>* (lhd xs) (llast xs)"
proof (induct rule: lfinite.induct)
  case (lfinite_LConsI xs x)
  note fin_xs = this(1) and ih = this(2) and r_x_xs = this(3)
  show ?case
  proof (cases "xs = LNil")
    case xs_nnil: False
    then have r_xs: "chain R xs"
      using r_x_xs by (blast elim: chain.cases)
    then show ?thesis
      using ih[OF r_xs] xs_nnil r_x_xs
      by (metis chain.cases converse_rtranclp_into_rtranclp lhd_LCons llast_LCons chain_not_lnull
          ltl_simps(2))
  qed simp
qed simp

lemma tranclp_imp_exists_finite_chain_list:
  "R\<^sup>+\<^sup>+ x y \<Longrightarrow> \<exists>xs. chain R (llist_of (x # xs @ [y]))"
proof (induct rule: tranclp.induct)
  case (r_into_trancl x y)
  then have "chain R (llist_of (x # [] @ [y]))"
    by (auto intro: chain.intros)
  then show ?case
    by blast
next
  case (trancl_into_trancl x y z)
  note rstar_xy = this(1) and ih = this(2) and r_yz = this(3)

  obtain xs where
    xs: "chain R (llist_of (x # xs @ [y]))"
    using ih by blast
  define ys where
    "ys = xs @ [y]"

  have "chain R (llist_of (x # ys @ [z]))"
    unfolding ys_def using r_yz chain_lappend[OF xs chain_singleton, of z]
    by (auto simp: lappend_llist_of_LCons llast_LCons)
  then show ?case
    by blast
qed

inductive_cases chain_consE: "chain R (LCons x xs)"
inductive_cases chain_nontrivE: "chain R (LCons x (LCons y xs))"

subsection \<open>A Coinductive Puzzle\<close>

primrec prepend where
  "prepend [] ys = ys"
| "prepend (x # xs) ys = LCons x (prepend xs ys)"

lemma lnull_prepend[simp]: "lnull (prepend xs ys) = (xs = [] \<and> lnull ys)"
  by (induct xs) auto

lemma lhd_prepend[simp]: "lhd (prepend xs ys) = (if xs \<noteq> [] then hd xs else lhd ys)"
  by (induct xs) auto

lemma lfinite_prepend[simp]: "lfinite (prepend xs ys) \<longleftrightarrow> lfinite ys"
  by (induct xs) auto

lemma llength_prepend[simp]: "llength (prepend xs ys) = length xs + llength ys"
  by (induct xs) (auto simp: enat_0 iadd_Suc eSuc_enat[symmetric])

lemma llast_prepend[simp]: "\<not> lnull ys \<Longrightarrow> llast (prepend xs ys) = llast ys"
  by (induct xs) (auto simp: llast_LCons)

lemma prepend_prepend: "prepend xs (prepend ys zs) = prepend (xs @ ys) zs"
  by (induct xs) auto

lemma chain_prepend:
  "chain R (llist_of zs) \<Longrightarrow> last zs = lhd xs \<Longrightarrow> chain R xs \<Longrightarrow> chain R (prepend zs (ltl xs))"
  by (induct zs; cases xs)
    (auto split: if_splits simp: lnull_def[symmetric] intro!: chain_cons elim!: chain_consE)

lemma lmap_prepend[simp]: "lmap f (prepend xs ys) = prepend (map f xs) (lmap f ys)"
  by (induct xs) auto

lemma lset_prepend[simp]: "lset (prepend xs ys) = set xs \<union> lset ys"
  by (induct xs) auto

lemma prepend_LCons: "prepend xs (LCons y ys) = prepend (xs @ [y]) ys"
  by (induct xs) auto

lemma lnth_prepend:
  "lnth (prepend xs ys) i = (if i < length xs then nth xs i else lnth ys (i - length xs))"
  by (induct xs arbitrary: i) (auto simp: lnth_LCons' nth_Cons')

theorem lfinite_less_induct[consumes 1, case_names less]:
  assumes fin: "lfinite xs"
    and step: "\<And>xs. lfinite xs \<Longrightarrow> (\<And>zs. llength zs < llength xs \<Longrightarrow> P zs) \<Longrightarrow> P xs"
  shows "P xs"
using fin proof (induct "the_enat (llength xs)" arbitrary: xs rule: less_induct)
  case (less xs)
  show ?case
    using less(2) by (intro step[OF less(2)] less(1))
      (auto dest!: lfinite_llength_enat simp: eSuc_enat elim!: less_enatE llength_eq_enat_lfiniteD)
qed

theorem lfinite_prepend_induct[consumes 1, case_names LNil prepend]:
  assumes "lfinite xs"
    and LNil: "P LNil"
    and prepend: "\<And>xs. lfinite xs \<Longrightarrow> (\<And>zs. (\<exists>ys. xs = prepend ys zs \<and> ys \<noteq> []) \<Longrightarrow> P zs) \<Longrightarrow> P xs"
  shows "P xs"
using assms(1) proof (induct xs rule: lfinite_less_induct)
  case (less xs)
  from less(1) show ?case
    by (cases xs)
      (force simp: LNil neq_Nil_conv dest: lfinite_llength_enat intro!: prepend[of "LCons _ _"] intro: less)+
qed

coinductive emb :: "'a llist \<Rightarrow> 'a llist \<Rightarrow> bool" where
  "lfinite xs \<Longrightarrow> emb LNil xs"
| "emb xs ys \<Longrightarrow> emb (LCons x xs) (prepend zs (LCons x ys))"

inductive_cases emb_LConsE: "emb (LCons z zs) ys"
inductive_cases emb_LNil1E: "emb LNil ys"
inductive_cases emb_LNil2E: "emb xs LNil"

lemma emb_lfinite:
  assumes "emb xs ys"
  shows "lfinite ys \<longleftrightarrow> lfinite xs"
proof
  assume "lfinite xs"
  then show "lfinite ys" using assms
    by (induct xs arbitrary: ys rule: lfinite_induct)
      (auto simp: lnull_def neq_LNil_conv elim!: emb_LNil1E emb_LConsE)
next
  assume "lfinite ys"
  then show "lfinite xs" using assms
  proof (induction ys arbitrary: xs rule: lfinite_less_induct)
    case (less ys)
    from less.prems \<open>lfinite ys\<close> show ?case
      by (cases xs)
        (auto simp: eSuc_enat elim!: emb_LNil1E emb_LConsE less.IH[rotated]
          dest!: lfinite_llength_enat)
  qed
qed

inductive prepend_cong1 for X where
  prepend_cong1_base: "X xs \<Longrightarrow> prepend_cong1 X xs"
| prepend_cong1_prepend: "prepend_cong1 X ys \<Longrightarrow> prepend_cong1 X (prepend xs ys)"

lemma emb_prepend_coinduct[rotated, case_names emb]:
  assumes "(\<And>x1 x2. X x1 x2 \<Longrightarrow>
    (\<exists>xs. x1 = LNil \<and> x2 = xs \<and> lfinite xs)
     \<or> (\<exists>xs ys x zs. x1 = LCons x xs \<and> x2 = prepend zs (LCons x ys)
       \<and> (prepend_cong1 (X xs) ys \<or> emb xs ys)))" (is "\<And>x1 x2. X x1 x2 \<Longrightarrow> ?bisim x1 x2")
  shows "X x1 x2 \<Longrightarrow> emb x1 x2"
proof (erule emb.coinduct[OF prepend_cong1_base])
  fix xs zs
  assume "prepend_cong1 (X xs) zs"
  then show "?bisim xs zs"
    by (induct zs rule: prepend_cong1.induct) (erule assms, force simp: prepend_prepend)
qed

context
begin

private coinductive chain' for R where
  "chain' R (LCons x LNil)"
| "chain R (llist_of (x # zs @ [lhd xs])) \<Longrightarrow>
   chain' R xs \<Longrightarrow> chain' R (LCons x (prepend zs xs))"

private lemma chain_imp_chain': "chain R xs \<Longrightarrow> chain' R xs"
proof (coinduction arbitrary: xs rule: chain'.coinduct)
  case chain'
  then show ?case
  proof (cases rule: chain.cases)
    case (chain_cons zs z)
    then show ?thesis
      by (intro disjI2 exI[of _ z] exI[of _ "[]"] exI[of _ "zs"])
        (auto intro: chain.intros)
  qed simp
qed

private lemma chain'_imp_chain: "chain' R xs \<Longrightarrow> chain R xs"
proof (coinduction arbitrary: xs rule: chain.coinduct)
  case chain
  then show ?case
  proof (cases rule: chain'.cases)
    case (2 y zs ys)
    then show ?thesis
      by (intro disjI2 exI[of _ "prepend zs ys"] exI[of _ y])
        (force dest!: neq_Nil_conv[THEN iffD1] elim: chain.cases chain_nontrivE
          intro: chain'.intros)
  qed simp
qed

private lemma chain_chain': "chain = chain'"
  unfolding fun_eq_iff by (metis chain_imp_chain' chain'_imp_chain)

lemma chain_prepend_coinduct[case_names chain]:
  "X x \<Longrightarrow> (\<And>x. X x \<Longrightarrow>
    (\<exists>z. x = LCons z LNil) \<or>
    (\<exists>y xs zs. x = LCons y (prepend zs xs) \<and>
      (X xs \<or> chain R xs) \<and> chain R (llist_of (y # zs @ [lhd xs])))) \<Longrightarrow> chain R x"
  by (subst chain_chain', erule chain'.coinduct) (force simp: chain_chain')

end

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

private definition pick where
  "pick x y = (SOME xs. chain R (llist_of (x # xs @ [y])))"

private lemma pick[simp]:
  assumes "R\<^sup>+\<^sup>+ x y"
  shows "chain R (llist_of (x # pick x y @ [y]))"
  unfolding pick_def using tranclp_imp_exists_finite_chain_list[THEN someI_ex, OF assms] by auto

private friend_of_corec prepend where
  "prepend xs ys = (case xs of [] \<Rightarrow>
    (case ys of LNil \<Rightarrow> LNil | LCons x xs \<Rightarrow> LCons x xs) | x # xs' \<Rightarrow> LCons x (prepend xs' ys))"
  by (simp split: list.splits llist.splits) transfer_prover

private corec wit where
  "wit xs = (case xs of LCons x (LCons y xs) \<Rightarrow>
     LCons x (prepend (pick x y) (wit (LCons y xs))) | _ \<Rightarrow> xs)"

private lemma
  wit_LNil[simp]: "wit LNil = LNil" and
  wit_lsingleton[simp]: "wit (LCons x LNil) = LCons x LNil" and
  wit_LCons2: "wit (LCons x (LCons y xs)) =
     (LCons x (prepend (pick x y) (wit (LCons y xs))))"
  by (subst wit.code; auto)+

private lemma lnull_wit[simp]: "lnull (wit xs) \<longleftrightarrow> lnull xs"
  by (subst wit.code) (auto split: llist.splits simp: Let_def)

private lemma lhd_wit[simp]: "chain R\<^sup>+\<^sup>+ xs \<Longrightarrow> lhd (wit xs) = lhd xs"
  by (erule chain.cases; subst wit.code) (auto split: llist.splits simp: Let_def)

private lemma LNil_eq_iff_lnull: "LNil = xs \<longleftrightarrow> lnull xs"
  by (cases xs) auto

lemma emb_wit[simp]: "chain R\<^sup>+\<^sup>+ xs \<Longrightarrow> emb xs (wit xs)"
proof (coinduction arbitrary: xs rule: emb_prepend_coinduct)
  case (emb xs)
  then show ?case
  proof (cases rule: chain.cases)
    case (chain_cons zs z)
    then show ?thesis
      by (subst (2) wit.code)
        (auto split: llist.splits intro!: exI[of _ "[]"] exI[of _ "_ :: _ llist"]
          prepend_cong1_prepend[OF prepend_cong1_base])
  qed (auto intro!: exI[of _ LNil] exI[of _ "[]"] emb.intros)
qed

private

private lemma llast_wit[simp]:
  assumes "chain R\<^sup>+\<^sup>+ xs"
  shows "llast (wit xs) = llast xs"
proof (cases "lfinite xs")
  case True
  from this assms show ?thesis
  proof (induct rule: lfinite.induct)
    case (lfinite_LConsI xs x)
    then show ?case
      by (cases xs) (auto simp: wit_LCons2 llast_LCons elim: chain_nontrivE)
  qed auto
qed (auto simp: llast_linfinite assms)

lemma chain_tranclp_imp_exists_chain:
  "chain R\<^sup>+\<^sup>+ xs \<Longrightarrow>
   \<exists>ys. chain R ys \<and> emb xs ys \<and> lhd ys = lhd xs \<and> llast ys = llast xs"
proof (intro exI[of _ "wit xs"] conjI, coinduction arbitrary: xs rule: chain_prepend_coinduct)
  case chain
  then show ?case
    by (subst (1 2) wit.code) (erule chain.cases; force split: llist.splits dest: pick)
qed auto

lemma emb_Ball_lset_antimono:
  assumes "emb Xs Ys"
  shows "\<forall>Y \<in> lset Ys. x \<in> Y \<Longrightarrow> \<forall>X \<in> lset Xs. x \<in> X"
  using emb_lset_mono[OF assms] by blast

lemma emb_lfinite_antimono[rotated]: "lfinite ys \<Longrightarrow> emb xs ys \<Longrightarrow> lfinite xs"
  by (induct ys arbitrary: xs rule: lfinite_prepend_induct)
    (force elim!: emb_LNil2E simp: LNil_eq_iff_lnull prepend_LCons elim: emb.cases)+

lemma emb_Liminf_llist_mono_aux:
  assumes "emb Xs Ys" and "\<not> lfinite Xs" and "\<not> lfinite Ys" and "\<forall>j\<ge>i. x \<in> lnth Ys j"
  shows "\<forall>j\<ge>i. x \<in> lnth Xs j"
using assms proof (induct i arbitrary: Xs Ys rule: less_induct)
  case (less i)
  then show ?case
  proof (cases i)
    case 0
    then show ?thesis
      using emb_Ball_lset_antimono[OF less(2), of x] less(5)
      unfolding Ball_def in_lset_conv_lnth simp_thms
        not_lfinite_llength[OF less(3)] not_lfinite_llength[OF less(4)] enat_ord_code subset_eq
      by blast
  next
    case [simp]: (Suc nat)
    from less(2,3) obtain xs as b bs where
      [simp]: "Xs = LCons b xs" "Ys = prepend as (LCons b bs)" and "emb xs bs"
      by (auto elim: emb.cases)
    have IH: "\<forall>k\<ge>j. x \<in> lnth xs k" if "\<forall>k\<ge>j. x \<in> lnth bs k" "j < i" for j
      using that less(1)[OF _ \<open>emb xs bs\<close>] less(3,4) by auto
    from less(5) have "\<forall>k\<ge>i - length as - 1. x \<in> lnth xs k"
      by (intro IH allI)
        (drule spec[of _ "_ + length as + 1"], auto simp: lnth_prepend lnth_LCons')
    then show ?thesis
      by (auto simp: lnth_LCons')
  qed
qed

lemma emb_Liminf_llist_infinite:
  assumes "emb Xs Ys" and "\<not> lfinite Xs"
  shows "Liminf_llist Ys \<subseteq> Liminf_llist Xs"
proof -
  from assms have "\<not> lfinite Ys"
    using emb_lfinite_antimono by blast
  with assms show ?thesis
    unfolding Liminf_llist_def by (auto simp: not_lfinite_llength dest: emb_Liminf_llist_mono_aux)
qed

lemma emb_lmap: "emb xs ys \<Longrightarrow> emb (lmap f xs) (lmap f ys)"
proof (coinduction arbitrary: xs ys rule: emb.coinduct)
  case emb
  show ?case
  proof (cases xs)
    case xs: (LCons x xs')

    obtain ysa0 and zs0 where
      ys: "ys = prepend zs0 (LCons x ysa0)" and
      emb': "emb xs' ysa0"
      using emb_LConsE[OF emb[unfolded xs]] by metis

    let ?xa = "f x"
    let ?xsa = "lmap f xs'"
    let ?zs = "map f zs0"
    let ?ysa = "lmap f ysa0"

    have "lmap f xs = LCons ?xa ?xsa"
      unfolding xs by simp
    moreover have "lmap f ys = prepend ?zs (LCons ?xa ?ysa)"
      unfolding ys by simp
    moreover have "\<exists>xsa ysa. ?xsa = lmap f xsa \<and> ?ysa = lmap f ysa \<and> emb xsa ysa"
      using emb' by blast
    ultimately show ?thesis
      by blast
  qed (simp add: emb_lfinite[OF emb])
qed

end

lemma chain_inf_llist_if_infinite_chain_function:
  assumes "\<forall>i. r (f (Suc i)) (f i)"
  shows "\<not> lfinite (inf_llist f) \<and> chain r\<inverse>\<inverse> (inf_llist f)"
  using assms by (simp add: lnth_rel_chain)

lemma infinite_chain_function_iff_infinite_chain_llist:
  "(\<exists>f. \<forall>i. r (f (Suc i)) (f i)) \<longleftrightarrow> (\<exists>c. \<not> lfinite c \<and> chain r\<inverse>\<inverse> c)"
  using chain_inf_llist_if_infinite_chain_function infinite_chain_lnth_rel by blast

lemma wfP_iff_no_infinite_down_chain_llist: "wfP r \<longleftrightarrow> (\<nexists>c. \<not> lfinite c \<and> chain r\<inverse>\<inverse> c)"
proof -
  have "wfP r \<longleftrightarrow>  wf {(x, y). r x y}"
    unfolding wfP_def by auto
  also have "\<dots> \<longleftrightarrow> (\<nexists>f. \<forall>i. (f (Suc i), f i) \<in> {(x, y). r x y})"
    using wf_iff_no_infinite_down_chain by blast
  also have "\<dots> \<longleftrightarrow> (\<nexists>f. \<forall>i. r (f (Suc i)) (f i))"
    by auto
  also have "\<dots> \<longleftrightarrow> (\<nexists>c. \<not>lfinite c \<and> chain r\<inverse>\<inverse> c)"
    using infinite_chain_function_iff_infinite_chain_llist by blast
  finally show ?thesis
    by auto
qed

subsection \<open>Full Chains\<close>

coinductive full_chain :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a llist \<Rightarrow> bool" for R :: "'a \<Rightarrow> 'a \<Rightarrow> bool" where
  full_chain_singleton: "(\<forall>y. \<not> R x y) \<Longrightarrow> full_chain R (LCons x LNil)"
| full_chain_cons: "full_chain R xs \<Longrightarrow> R x (lhd xs) \<Longrightarrow> full_chain R (LCons x xs)"

lemma
  full_chain_LNil[simp]: "\<not> full_chain R LNil" and
  full_chain_not_lnull: "full_chain R xs \<Longrightarrow> \<not> lnull xs"
  by (auto elim: full_chain.cases)

lemma full_chain_ldropn:
  assumes full: "full_chain R xs" and "enat n < llength xs"
  shows "full_chain R (ldropn n xs)"
  using assms
  by (induct n arbitrary: xs, simp,
      metis full_chain.cases ldrop_eSuc_ltl ldropn_LNil ldropn_eq_LNil ltl_simps(2) not_less)

lemma full_chain_iff_chain:
  "full_chain R xs \<longleftrightarrow> chain R xs \<and> (lfinite xs \<longrightarrow> (\<forall>y. \<not> R (llast xs) y))"
proof (intro iffI conjI impI allI; (elim conjE)?)
  assume full: "full_chain R xs"

  show chain: "chain R xs"
    using full by (coinduction arbitrary: xs) (auto elim: full_chain.cases)

  {
    fix y
    assume "lfinite xs"
    then obtain n where
      suc_n: "Suc n = llength xs"
      by (metis chain chain_length_pos lessE less_enatE lfinite_conv_llength_enat)

    have "full_chain R (ldropn n xs)"
      by (rule full_chain_ldropn[OF full]) (use suc_n Suc_ile_eq in force)
    moreover have "ldropn n xs = LCons (llast xs) LNil"
      using suc_n by (metis enat_le_plus_same(2) enat_ord_simps(2) gen_llength_def
          ldropn_Suc_conv_ldropn ldropn_all lessI llast_ldropn llast_singleton llength_code)
    ultimately show "\<not> R (llast xs) y"
      by (auto elim: full_chain.cases)
  }
next
  assume
    "chain R xs" and
    "lfinite xs \<longrightarrow> (\<forall>y. \<not> R (llast xs) y)"
  then show "full_chain R xs"
    by (coinduction arbitrary: xs) (erule chain.cases, simp, metis lfinite_LConsI llast_LCons)
qed

lemma full_chain_imp_chain: "full_chain R xs \<Longrightarrow> chain R xs"
  using full_chain_iff_chain by blast

lemma full_chain_length_pos: "full_chain R xs \<Longrightarrow> llength xs > 0"
  by (fact chain_length_pos[OF full_chain_imp_chain])

lemma full_chain_lnth_rel:
  "full_chain R xs \<Longrightarrow> enat (Suc j) < llength xs \<Longrightarrow> R (lnth xs j) (lnth xs (Suc j))"
  by (fact chain_lnth_rel[OF full_chain_imp_chain])

lemma full_chain_lnth_not_rel:
  assumes
    full: "full_chain R xs" and
    sj: "enat (Suc j) = llength xs"
  shows "\<not> R (lnth xs j) y"
proof -
  have "lfinite xs"
    by (metis llength_eq_enat_lfiniteD sj)
  hence "\<not> R (llast xs) y"
    using full_chain_iff_chain full by metis
  thus ?thesis
    by (metis eSuc_enat llast_conv_lnth sj)
qed

inductive_cases full_chain_consE: "full_chain R (LCons x xs)"
inductive_cases full_chain_nontrivE: "full_chain R (LCons x (LCons y xs))"

lemma full_chain_tranclp_imp_exists_full_chain:
  assumes full: "full_chain R\<^sup>+\<^sup>+ xs"
  shows "\<exists>ys. full_chain R ys \<and> emb xs ys \<and> lhd ys = lhd xs \<and> llast ys = llast xs"
proof -
  obtain ys where ys:
    "chain R ys" "emb xs ys" "lhd ys = lhd xs" "llast ys = llast xs"
    using full_chain_imp_chain[OF full] chain_tranclp_imp_exists_chain by blast
  have "full_chain R ys"
    using ys(1,4) emb_lfinite[OF ys(2)] full unfolding full_chain_iff_chain by auto
  then show ?thesis
    using ys(2-4) by auto
qed

end