(*
  File:      Treap.thy
  Authors:   Tobias Nipkow, Max Haslbeck
*)
section \<open>Treaps\<close>
theory Treap
imports
  "HOL-Library.Tree"
begin

definition treap :: "('k::linorder * 'p::linorder) tree \<Rightarrow> bool" where
"treap t = (bst (map_tree fst t) \<and> heap (map_tree snd t))"

abbreviation "keys t \<equiv> set_tree (map_tree fst t)"
abbreviation "prios t \<equiv> set_tree (map_tree snd t)"

function treap_of :: "('k::linorder * 'p::linorder) set \<Rightarrow> ('k * 'p) tree" where
"treap_of KP = (if infinite KP \<or> KP = {} then Leaf else
  let m = arg_min_on snd KP;
      L = {p \<in> KP. fst p < fst m};
      R = {p \<in> KP. fst p > fst m}
  in Node (treap_of L) m (treap_of R))"
by pat_completeness auto
termination
proof (relation "measure card")
  show "wf (measure card)"  by simp
next
  fix KP :: "('a \<times> 'b) set" and m L
  assume KP: "\<not> (infinite KP \<or> KP = {})"
  and m: "m = arg_min_on snd KP"
  and L: "L = {p \<in> KP. fst p < fst m}"
  have "m \<in> KP" using KP arg_min_if_finite(1) m by blast
  thus  "(L, KP) \<in> measure card" using KP L by(auto intro!: psubset_card_mono)
next
  fix KP :: "('a \<times> 'b) set" and m R
  assume KP: "\<not> (infinite KP \<or> KP = {})"
  and m: "m = arg_min_on snd KP"
  and R: "R = {p \<in> KP. fst m < fst p}"
  have "m \<in> KP" using KP arg_min_if_finite(1) m by blast
  thus  "(R, KP) \<in> measure card" using KP R by(auto intro!: psubset_card_mono)
qed

declare treap_of.simps [simp del]

lemma treap_of_unique:
  "\<lbrakk> treap t;  inj_on snd (set_tree t) \<rbrakk>
  \<Longrightarrow> treap_of (set_tree t) = t"
proof(induction "set_tree t" arbitrary: t rule: treap_of.induct)
  case (1 t)
  show ?case
  proof (cases "infinite (set_tree t) \<or> set_tree t = {}")
    case True
    thus ?thesis by(simp add: treap_of.simps)
  next
    case False
    let ?m = "arg_min_on snd (set_tree t)"
    let ?L = "{p \<in> set_tree t. fst p < fst ?m}"
    let ?R = "{p \<in> set_tree t. fst p > fst ?m}"
    obtain l a r where t: "t = Node l a r"
      using False by (cases t) auto
    have "\<forall>kp \<in> set_tree t. snd a \<le> snd kp"
      using "1.prems"(1)
      by(auto simp add: t treap_def ball_Un)
        (metis image_eqI snd_conv tree.set_map)+
    hence "a = ?m"
      by (metis "1.prems"(2) False arg_min_if_finite(1) arg_min_if_finite(2) inj_on_def
          le_neq_trans t tree.set_intros(2))
    have "treap l" "treap r" using "1.prems"(1) by(auto simp: treap_def t)
    have l: "set_tree l = {p \<in> set_tree t. fst p < fst a}"
      using "1.prems"(1) by(auto simp add: treap_def t ball_Un tree.set_map)
    have r: "set_tree r = {p \<in> set_tree t. fst p > fst a}"
      using "1.prems"(1) by(auto simp add: treap_def t ball_Un tree.set_map)
    have "l = treap_of ?L"
      using "1.hyps"(1)[OF False \<open>a = ?m\<close> l r \<open>treap l\<close>]
        l \<open>a = ?m\<close> "1.prems"(2)
      by (fastforce simp add: inj_on_def)
    have "r = treap_of ?R"
      using "1.hyps"(2)[OF False \<open>a = ?m\<close> l r \<open>treap r\<close>]
        r \<open>a = ?m\<close> "1.prems"(2)
      by (fastforce simp add: inj_on_def)
    have "t = Node (treap_of ?L) ?m (treap_of ?R)"
      using \<open>a = ?m\<close> \<open>l = treap_of ?L\<close> \<open>r = treap_of ?R\<close> by(subst t) simp
    thus ?thesis using False
      by (subst treap_of.simps) simp
  qed
qed

lemma treap_unique:
  "\<lbrakk> treap t1; treap t2; set_tree t1 = set_tree t2; inj_on snd (set_tree t1) \<rbrakk>
  \<Longrightarrow> t1 = t2"
  for t1 t2 :: "('k::linorder * 'p::linorder) tree"
by (metis treap_of_unique)

fun ins :: "'k::linorder \<Rightarrow> 'p::linorder \<Rightarrow> ('k \<times> 'p) tree \<Rightarrow> ('k \<times> 'p) tree" where
"ins k p Leaf = \<langle>Leaf, (k,p), Leaf\<rangle>" |
"ins k p \<langle>l, (k1,p1), r\<rangle> =
  (if k < k1 then
     (case ins k p l of
       \<langle>l2, (k2,p2), r2\<rangle> \<Rightarrow>
         if p1 \<le> p2 then \<langle>\<langle>l2, (k2,p2), r2\<rangle>, (k1,p1), r\<rangle>
         else \<langle>l2, (k2,p2), \<langle>r2, (k1,p1), r\<rangle>\<rangle>)
   else
   if k > k1 then
     (case ins k p r of
       \<langle>l2, (k2,p2), r2\<rangle> \<Rightarrow>
         if p1 \<le> p2 then \<langle>l, (k1,p1), \<langle>l2, (k2,p2), r2\<rangle>\<rangle>
         else \<langle>\<langle>l, (k1,p1), l2\<rangle>, (k2,p2), r2\<rangle>)
   else \<langle>l, (k1,p1), r\<rangle>)"

lemma ins_neq_Leaf: "ins k p t \<noteq> \<langle>\<rangle>"
  by (induction t rule: ins.induct) (auto split: tree.split)

lemma keys_ins: "keys (ins k p t) = Set.insert k (keys t)"
proof (induction t rule: ins.induct)
  case 2
  then show ?case
    by (simp add: ins_neq_Leaf split: tree.split prod.split) (safe; fastforce)
qed (simp)

lemma prios_ins: "prios (ins k p t) \<subseteq> {p} \<union> prios t"
apply(induction t rule: ins.induct)
 apply simp
  apply (simp add: ins_neq_Leaf split: tree.split prod.split)
  by (safe; fastforce)

lemma prios_ins': "k \<notin> keys t \<Longrightarrow> prios (ins k p t) = {p} \<union> prios t"
apply(induction t rule: ins.induct)
 apply simp
  apply (simp add: ins_neq_Leaf split: tree.split prod.split)
  by (safe; fastforce)

lemma set_tree_ins: "set_tree (ins k p t) \<subseteq> {(k,p)} \<union> set_tree t"
  by (induction t rule: ins.induct) (auto simp add: ins_neq_Leaf split: tree.split prod.split)

lemma set_tree_ins': "k \<notin> keys t \<Longrightarrow>  {(k,p)} \<union> set_tree t \<subseteq> set_tree (ins k p t)"
  by (induction t rule: ins.induct) (auto simp add: ins_neq_Leaf split: tree.split prod.split)

lemma set_tree_ins_eq: "k \<notin> keys t \<Longrightarrow> set_tree (ins k p t) = {(k,p)} \<union> set_tree t"
  using set_tree_ins set_tree_ins' by blast

lemma prios_ins_special:
  "\<lbrakk> ins k p t = Node l (k',p') r;  p' = p; p \<in> prios r \<union> prios l \<rbrakk>
  \<Longrightarrow> p \<in> prios t"
  by (induction k p t arbitrary: l k' p' r rule: ins.induct)
     (fastforce simp add: ins_neq_Leaf split: tree.splits prod.splits if_splits)+

lemma treap_NodeI:
  "\<lbrakk> treap l; treap r;
     \<forall>k' \<in> keys l. k' < k; \<forall>k' \<in> keys r. k < k';
     \<forall>p' \<in> prios l. p \<le> p'; \<forall>p' \<in> prios r. p \<le> p' \<rbrakk>
  \<Longrightarrow> treap (Node l (k,p) r)"
 by (auto simp: treap_def)

lemma treap_rotate1:
  assumes "treap l2" "treap r2" "treap r" "\<not> p1 \<le> p2" "k < k1" and
  ins: "ins k p l = Node l2 (k2,p2) r2" and treap_ins: "treap (ins k p l)"
  and treap: "treap \<langle>l, (k1, p1), r\<rangle>"
  shows "treap (Node l2 (k2,p2) (Node r2 (k1,p1) r))"
proof(rule treap_NodeI[OF \<open>treap l2\<close> treap_NodeI[OF \<open>treap r2\<close> \<open>treap r\<close>]])
  from keys_ins[of k p l] have 1: "keys r2 \<subseteq> {k} \<union> keys l" by(auto simp: ins)
  from treap have 2: "\<forall>k'\<in>keys l. k' < k1" by (simp add: treap_def)
  show "\<forall>k'\<in>keys r2. k' < k1" using 1 2 \<open>k < k1\<close> by blast
next
  from treap have 2: "\<forall>p'\<in>prios l. p1 \<le> p'" by (simp add: treap_def)
  show "\<forall>p'\<in>prios r2. p1 \<le> p'"
  proof
    fix p' assume "p' \<in> prios r2"
    hence "p' = p \<or> p' \<in> prios l" using prios_ins[of k p l] ins by auto
    thus "p1 \<le> p'"
    proof
      assume [simp]: "p' = p"
      have "p2 = p \<or> p2 \<in> prios l" using prios_ins[of k p l] ins by simp
      thus "p1 \<le> p'"
      proof
        assume "p2 = p"
        thus "p1 \<le> p'"
          using prios_ins_special[OF ins] \<open>p' \<in> prios r2\<close> 2 by auto
      next
        assume "p2 \<in> prios l"
        thus "p1 \<le> p'" using 2 \<open>\<not> p1 \<le> p2\<close> by blast
      qed
    next
      assume "p' \<in> prios l"
      thus "p1 \<le> p'" using 2 by blast
    qed
  qed
next
  have "k2 = k \<or> k2 \<in> keys l" using keys_ins[of k p l] ins by (auto)
  hence 1: "k2 < k1"
  proof
    assume "k2 = k" thus "k2 < k1" using \<open>k < k1\<close> by simp
  next
    assume "k2 \<in> keys l"
    thus "k2 < k1" using treap by (auto simp: treap_def)
  qed
  have 2: "\<forall>k'\<in>keys r2. k2 < k'"
    using treap_ins by(simp add: ins treap_def)
  have 3: "\<forall>k'\<in>keys r. k2 < k'"
    using 1 treap by(auto simp: treap_def)
  show "\<forall>k'\<in>keys \<langle>r2, (k1, p1), r\<rangle>. k2 < k'" using 1 2 3 by auto
next
  show "\<forall>p'\<in>prios \<langle>r2, (k1, p1), r\<rangle>. p2 \<le> p'"
    using ins treap_ins treap \<open>\<not> p1 \<le> p2\<close> by (auto simp: treap_def ball_Un)
qed (use ins treap_ins treap in \<open>auto simp: treap_def ball_Un\<close>)

lemma treap_rotate2:
  assumes "treap l" "treap l2" "treap r2" "\<not> p1 \<le> p2" "k1 < k" and
  ins: "ins k p r = Node l2 (k2,p2) r2" and treap_ins: "treap (ins k p r)"
  and treap: "treap \<langle>l, (k1, p1), r\<rangle>"
  shows "treap (Node (Node l (k1,p1) l2) (k2,p2) r2)"
proof(rule treap_NodeI[OF treap_NodeI[OF \<open>treap l\<close> \<open>treap l2\<close>] \<open>treap r2\<close>])
  from keys_ins[of k p r] have 1: "keys l2 \<subseteq> {k} \<union> keys r" by(auto simp: ins)
  from treap have 2: "\<forall>k'\<in>keys r. k1 < k'" by (simp add: treap_def)
  show "\<forall>k'\<in>keys l2. k1 < k'" using 1 2 \<open>k1 < k\<close> by blast
next
  from treap have 2: "\<forall>p'\<in>prios r. p1 \<le> p'" by (simp add: treap_def)
  show "\<forall>p'\<in>prios l2. p1 \<le> p'"
  proof
    fix p' assume "p' \<in> prios l2"
    hence "p' = p \<or> p' \<in> prios r" using prios_ins[of k p r] ins by auto
    thus "p1 \<le> p'"
    proof
      assume [simp]: "p' = p"
      have "p2 = p \<or> p2 \<in> prios r" using prios_ins[of k p r] ins by simp
      thus "p1 \<le> p'"
      proof
        assume "p2 = p"
        thus "p1 \<le> p'"
          using prios_ins_special[OF ins] \<open>p' \<in> prios l2\<close> 2 by auto
      next
        assume "p2 \<in> prios r"
        thus "p1 \<le> p'" using 2 \<open>\<not> p1 \<le> p2\<close> by blast
      qed
    next
      assume "p' \<in> prios r"
      thus "p1 \<le> p'" using 2 by blast
    qed
  qed
next
  have "k2 = k \<or> k2 \<in> keys r" using keys_ins[of k p r] ins by (auto)
  hence 1: "k1 < k2"
  proof
    assume "k2 = k" thus "k1 < k2" using \<open>k1 < k\<close> by simp
  next
    assume "k2 \<in> keys r"
    thus "k1 < k2" using treap by (auto simp: treap_def)
  qed
  have 2: "\<forall>k'\<in>keys l. k' < k2" using 1 treap by(auto simp: treap_def)
  have 3: "\<forall>k'\<in>keys l2. k' < k2"
    using treap_ins by(auto simp: ins treap_def)
  show "\<forall>k'\<in>keys \<langle>l, (k1, p1), l2\<rangle>. k' < k2" using 1 2 3 by auto
next
  show "\<forall>p'\<in>prios \<langle>l, (k1, p1), l2\<rangle>. p2 \<le> p'"
    using ins treap_ins treap \<open>\<not> p1 \<le> p2\<close> by (auto simp: treap_def ball_Un)
qed (use ins treap_ins treap in \<open>auto simp: treap_def ball_Un\<close>)

lemma treap_ins: "treap t \<Longrightarrow> treap (ins k p t)"
proof(induction t rule: ins.induct)
  case 1 thus ?case by (simp add: treap_def)
next
  case (2 k p l k1 p1 r)
  have "treap l" "treap r"
    using "2.prems" by(auto simp: treap_def tree.set_map)
  show ?case
  proof cases
    assume "k < k1"
    obtain l2 k2 p2 r2 where ins: "ins k p l = Node l2 (k2,p2) r2"
      by (metis ins_neq_Leaf neq_Leaf_iff prod.collapse)
    note treap_ins = "2.IH"(1)[OF \<open>k < k1\<close> \<open>treap l\<close>]
    hence "treap l2" "treap r2" using ins by (auto simp add: treap_def)
    show ?thesis
    proof cases
      assume "p1 \<le> p2"
      have "treap (Node (Node l2 (k2,p2) r2) (k1,p1) r)"
        apply(rule treap_NodeI[OF treap_ins[unfolded ins] \<open>treap r\<close>])
        using ins treap_ins \<open>k < k1\<close> "2.prems" keys_ins[of k p l]
        by (auto simp add: treap_def ball_Un order_trans[OF \<open>p1 \<le> p2\<close>])
      thus ?thesis using \<open>k < k1\<close> ins \<open>p1 \<le> p2\<close> by simp
    next
      assume "\<not> p1 \<le> p2"
      have "treap (Node l2 (k2,p2) (Node r2 (k1,p1) r))"
        by(rule treap_rotate1[OF \<open>treap l2\<close> \<open>treap r2\<close>  \<open>treap r\<close> \<open>\<not> p1 \<le> p2\<close>
            \<open>k < k1\<close> ins treap_ins "2.prems"])
      thus ?thesis using \<open>k < k1\<close> ins \<open>\<not> p1 \<le> p2\<close> by simp
    qed
  next
    assume "\<not> k < k1"
    show ?thesis
    proof cases
    assume "k > k1"
    obtain l2 k2 p2 r2 where ins: "ins k p r = Node l2 (k2,p2) r2"
      by (metis ins_neq_Leaf neq_Leaf_iff prod.collapse)
    note treap_ins = "2.IH"(2)[OF \<open>\<not> k < k1\<close> \<open>k > k1\<close> \<open>treap r\<close>]
    hence "treap l2" "treap r2" using ins by (auto simp add: treap_def)
    have fst: "\<forall>k' \<in> set_tree (map_tree fst (ins k p r)).
                 k' = k \<or> k' \<in> set_tree (map_tree fst r)"
      by(simp add: keys_ins)
    show ?thesis
    proof cases
      assume "p1 \<le> p2"
      have "treap (Node l (k1,p1) (ins k p r))"
        apply(rule treap_NodeI[OF \<open>treap l\<close> treap_ins])
        using ins treap_ins \<open>k > k1\<close> "2.prems" keys_ins[of k p r]
        by (auto simp: treap_def ball_Un order_trans[OF \<open>p1 \<le> p2\<close>])
      thus ?thesis using \<open>\<not> k < k1\<close> \<open>k > k1\<close> ins \<open>p1 \<le> p2\<close> by simp
    next
      assume "\<not> p1 \<le> p2"
      have "treap (Node (Node l (k1,p1) l2) (k2,p2) r2)"
        by(rule treap_rotate2[OF \<open>treap l\<close> \<open>treap l2\<close> \<open>treap r2\<close> \<open>\<not> p1 \<le> p2\<close>
             \<open>k1 < k\<close> ins treap_ins "2.prems"])
      thus ?thesis using \<open>\<not> k < k1\<close>  \<open>k > k1\<close> ins \<open>\<not> p1 \<le> p2\<close> by simp
    qed
    next
      assume "\<not> k > k1"
      hence "k = k1" using \<open>\<not> k < k1\<close> by auto
      thus ?thesis using "2.prems" by(simp)
    qed
  qed
qed

lemma treap_of_set_tree_unique:
  "\<lbrakk> finite A; inj_on fst A; inj_on snd A \<rbrakk>
  \<Longrightarrow> set_tree (treap_of A) = A"
proof(induction "A" rule: treap_of.induct)
  case (1 A)
  note IH = 1
  show ?case
  proof (cases "infinite A \<or> A = {}")
    assume "infinite A \<or> A = {}"
    with IH show ?thesis by (simp add: treap_of.simps)
  next
    assume not_inf_or_empty: "\<not> (infinite A \<or> A = {})"
    let ?m = "arg_min_on snd A"
    let ?L = "{p \<in> A. fst p < fst ?m}"
    let ?R = "{p \<in> A. fst p > fst ?m}"
    obtain l a r where t: "treap_of A = Node l a r"
      using not_inf_or_empty
      by (cases "treap_of A") (auto simp: Let_def elim!: treap_of.elims split: if_splits)
    have [simp]: "inj_on fst {p \<in> A. fst p < fst (arg_min_on snd A)}"
                 "inj_on snd {p \<in> A. fst p < fst (arg_min_on snd A)}"
                 "inj_on fst {p \<in> A. fst (arg_min_on snd A) < fst p}"
                 "inj_on snd {p \<in> A. fst (arg_min_on snd A) < fst p}"
      using IH by (auto intro: inj_on_subset)
    have lr: "l = treap_of ?L" "r = treap_of ?R"
      using t by (auto simp: Let_def elim: treap_of.elims split: if_splits)
    then have l: "set_tree l = ?L"
       using not_inf_or_empty IH by auto
     have "r = treap_of ?R"
       using t by (auto simp: Let_def elim: treap_of.elims split: if_splits)
    then have r: "set_tree r = ?R"
      using not_inf_or_empty IH(2) by (auto)
    have a: "a = ?m"
      using t by (elim treap_of.elims) (simp add: Let_def split: if_splits)
    have "a \<noteq> fst (arg_min_on snd A)" if "(a,b) \<in> A" "(a, b) \<noteq> arg_min_on snd A" for a b
      using IH(4,5) that not_inf_or_empty arg_min_if_finite(1) inj_on_eq_iff by fastforce
    then have "a < fst (arg_min_on snd A)"
       if "(a,b) \<in> A" "(a, b) \<noteq> arg_min_on snd A" "fst (arg_min_on snd A) \<ge> a" for a b
      using le_neq_trans that by auto
    moreover have "arg_min_on snd A \<in> A"
      using not_inf_or_empty arg_min_if_finite by auto
    ultimately have A: "A = {?m} \<union> ?L \<union> ?R"
      by auto
    show ?thesis using l r a A t by force
  qed
qed

lemma treap_of_subset: "set_tree (treap_of A) \<subseteq> A"
proof(induction "A" rule: treap_of.induct)
  case (1 A)
  note IH = 1
  show ?case
  proof (cases "infinite A \<or> A = {}")
    assume "infinite A \<or> A = {}"
    with IH show ?thesis by (simp add: treap_of.simps)
  next
    assume not_inf_or_empty: "\<not> (infinite A \<or> A = {})"
    let ?m = "arg_min_on snd A"
    let ?L = "{p \<in> A. fst p < fst ?m}"
    let ?R = "{p \<in> A. fst p > fst ?m}"
    obtain l a r where t: "treap_of A = Node l a r"
      using not_inf_or_empty by (cases "treap_of A")
                                (auto simp add: Let_def  elim!: treap_of.elims split: if_splits)
    have "l = treap_of ?L" "r = treap_of ?R"
      using t by (auto simp: Let_def elim: treap_of.elims split: if_splits)
    have "set_tree l \<subseteq> ?L" "set_tree r \<subseteq> ?R"
    proof -
      have "set_tree (treap_of {p \<in> A. fst p < fst (arg_min_on snd A)})
            \<subseteq> {p \<in> A. fst p < fst (arg_min_on snd A)}"
        by (rule IH) (use not_inf_or_empty in auto)
      then show "set_tree l \<subseteq> ?L"
        using \<open>l = treap_of ?L\<close> by auto
    next
      have "set_tree (treap_of {p \<in> A. fst (arg_min_on snd A) < fst p})
            \<subseteq> {p \<in> A. fst (arg_min_on snd A) < fst p}"
        by (rule IH) (use not_inf_or_empty in auto)
      then show "set_tree r \<subseteq> ?R"
        using \<open>r = treap_of ?R\<close> by auto
    qed
    moreover have "a = ?m"
      using t by (auto elim!: treap_of.elims simp add: Let_def split: if_splits)
    moreover have "{?m} \<union> ?L \<union> ?R \<subseteq> A"
      using not_inf_or_empty arg_min_if_finite by auto
    ultimately show ?thesis by (auto simp add: t)
  qed
qed

lemma treap_treap_of:
  "treap (treap_of A)"
proof(induction "A" rule: treap_of.induct)
  case (1 A)
  show ?case
  proof (cases "infinite A \<or> A = {}")
    case True
    with 1 show ?thesis by (simp add: treap_of.simps treap_def)
  next
    case False
    let ?m = "arg_min_on snd A"
    let ?L = "{p \<in> A. fst p < fst ?m}"
    let ?R = "{p \<in> A. fst p > fst ?m}"
    obtain l a r where t: "treap_of A = Node l a r"
      using False by (cases "treap_of A") (auto simp: Let_def elim!: treap_of.elims split: if_splits)
    have l: "l = treap_of ?L"
      using t by (auto simp: Let_def elim: treap_of.elims split: if_splits)
    then have treap_l: "treap l"
      using False by (auto intro: 1)
    from l have keys_l: "keys l \<subseteq> fst ` ?L"
      by (auto simp add: tree.set_map intro!: image_mono treap_of_subset)
    have r: "r = treap_of ?R"
      using t by (auto simp: Let_def elim: treap_of.elims split: if_splits)
    then have treap_r: "treap r"
      using False by (auto intro: 1)
    from r have keys_r: "keys r \<subseteq> fst ` ?R"
      by (auto simp add: tree.set_map intro!: image_mono treap_of_subset)
    have prios: "prios l \<subseteq> snd ` A" "prios r \<subseteq> snd ` A"
      using l r treap_of_subset image_mono by (auto simp add: tree.set_map)
    have a: "a = ?m"
      using t by(auto simp: Let_def elim: treap_of.elims split: if_splits)
    have prios_l: "\<And>x. x \<in> prios l \<Longrightarrow> snd a \<le> x"
      by (drule rev_subsetD[OF _ prios(1)]) (use arg_min_least a False in fast)
    have prios_r: "\<And>x. x \<in> prios r \<Longrightarrow> snd a \<le> x"
      by (drule rev_subsetD[OF _ prios(2)]) (use arg_min_least a False in fast)
    show ?thesis
      using prios_r prios_l treap_l treap_r keys_l keys_r a
      by (auto simp add: t treap_def dest: rev_subsetD[OF _ keys_l] rev_subsetD[OF _ keys_r])
    qed
qed

lemma treap_Leaf: "treap \<langle>\<rangle>"
  by (simp add: treap_def)

lemma foldl_ins_treap: "treap t \<Longrightarrow> treap (foldl (\<lambda>t' (x, p). ins x p t') t xs)"
  using treap_ins by (induction xs arbitrary: t) auto

lemma foldl_ins_set_tree:
  assumes "inj_on fst (set ys)" "inj_on snd (set ys)" "distinct ys" "fst ` (set ys) \<inter> keys t = {}"
  shows "set_tree (foldl (\<lambda>t' (x, p). ins x p t') t ys) = set ys \<union> set_tree t"
  using assms
  by (induction ys arbitrary: t) (auto simp add: case_prod_beta' set_tree_ins_eq keys_ins)

lemma foldl_ins_treap_of:
  assumes "distinct ys" "inj_on fst (set ys)" "inj_on snd (set ys)"
 shows "(foldl (\<lambda>t' (x, p). ins x p t') Leaf ys) = treap_of (set ys)"
  using assms by (intro treap_unique) (auto simp: treap_Leaf foldl_ins_treap foldl_ins_set_tree
                                                  treap_treap_of treap_of_set_tree_unique)

end


theory T15
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(meet(x, y), z) = meet(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(x, join(y, z)) = join(undr(x, y), undr(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(join(x, y), z) = join(over(x, z), over(y, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, meet(y, z)) = meet(mult(x, y), mult(x, z)))
"
nitpick[card nat=4,timeout=86400]
oops
end


(*  Title:      Well-Quasi-Orders
    Author:     Christian Sternagel <c.sternagel@gmail.com>
    Maintainer: Christian Sternagel
    License:    LGPL
*)

section \<open>Binary Predicates Restricted to Elements of a Given Set\<close>

theory Restricted_Predicates
imports Main
begin

text \<open>
  A subset \<open>C\<close> of \<open>A\<close> is a \emph{chain} on \<open>A\<close> (w.r.t.\ \<open>P\<close>)
  iff for all pairs of elements of \<open>C\<close>, one is less than or equal
  to the other one.
\<close>
abbreviation "chain_on P C A \<equiv> pred_on.chain A P C"
lemmas chain_on_def = pred_on.chain_def

lemma chain_on_subset:
  "A \<subseteq> B \<Longrightarrow> chain_on P C A \<Longrightarrow> chain_on P C B"
by (force simp: chain_on_def)

lemma chain_on_imp_subset:
  "chain_on P C A \<Longrightarrow> C \<subseteq> A"
by (simp add: chain_on_def)

lemma subchain_on:
  assumes "C \<subseteq> D" and "chain_on P D A"
  shows "chain_on P C A"
using assms by (auto simp: chain_on_def)

definition restrict_to :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a set \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> bool)" where
  "restrict_to P A = (\<lambda>x y. x \<in> A \<and> y \<in> A \<and> P x y)"

abbreviation "strict P \<equiv> \<lambda>x y. P x y \<and> \<not> (P y x)"

abbreviation "incomparable P \<equiv> \<lambda>x y. \<not> P x y \<and> \<not> P y x"

abbreviation "antichain_on P f A \<equiv> \<forall>(i::nat) j. f i \<in> A \<and> (i < j \<longrightarrow> incomparable P (f i) (f j))"

lemma strict_reflclp_conv [simp]:
  "strict (P\<^sup>=\<^sup>=) = strict P" by auto

lemma reflp_on_reflclp_simp [simp]:
  assumes "reflp_on A P" and "a \<in> A" and "b \<in> A"
  shows "P\<^sup>=\<^sup>= a b = P a b"
  using assms by (auto simp: reflp_on_def)

lemmas reflp_on_converse_simp = reflp_on_conversp
lemmas irreflp_on_converse_simp = irreflp_on_converse
lemmas transp_on_converse_simp = transp_on_conversep

lemma transp_on_strict:
  "transp_on A P \<Longrightarrow> transp_on A (strict P)"
  unfolding transp_on_def by blast

definition wfp_on :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a set \<Rightarrow> bool"
where
  "wfp_on P A \<longleftrightarrow> \<not> (\<exists>f. \<forall>i. f i \<in> A \<and> P (f (Suc i)) (f i))"

definition inductive_on :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a set \<Rightarrow> bool" where
  "inductive_on P A \<longleftrightarrow> (\<forall>Q. (\<forall>y\<in>A. (\<forall>x\<in>A. P x y \<longrightarrow> Q x) \<longrightarrow> Q y) \<longrightarrow> (\<forall>x\<in>A. Q x))"

lemma inductive_onI [Pure.intro]:
  assumes "\<And>Q x. \<lbrakk>x \<in> A; (\<And>y. \<lbrakk>y \<in> A; \<And>x. \<lbrakk>x \<in> A; P x y\<rbrakk> \<Longrightarrow> Q x\<rbrakk> \<Longrightarrow> Q y)\<rbrakk> \<Longrightarrow>  Q x"
  shows "inductive_on P A"
  using assms unfolding inductive_on_def by metis

text \<open>
  If @{term P} is well-founded on @{term A} then every non-empty subset @{term Q} of @{term A} has a
  minimal element @{term z} w.r.t. @{term P}, i.e., all elements that are @{term P}-smaller than
  @{term z} are not in @{term Q}.
\<close>
lemma wfp_on_imp_minimal:
  assumes "wfp_on P A"
  shows "\<forall>Q x. x \<in> Q \<and> Q \<subseteq> A \<longrightarrow> (\<exists>z\<in>Q. \<forall>y. P y z \<longrightarrow> y \<notin> Q)"
proof (rule ccontr)
  assume "\<not> ?thesis"
  then obtain Q x where *: "x \<in> Q" "Q \<subseteq> A"
    and "\<forall>z. \<exists>y. z \<in> Q \<longrightarrow> P y z \<and> y \<in> Q" by metis
  from choice [OF this(3)] obtain f
    where **: "\<forall>x\<in>Q. P (f x) x \<and> f x \<in> Q" by blast
  let ?S = "\<lambda>i. (f ^^ i) x"
  have ***: "\<forall>i. ?S i \<in> Q"
  proof
    fix i show "?S i \<in> Q" by (induct i) (auto simp: * **)
  qed
  then have "\<forall>i. ?S i \<in> A" using * by blast
  moreover have "\<forall>i. P (?S (Suc i)) (?S i)"
  proof
    fix i show "P (?S (Suc i)) (?S i)"
      by (induct i) (auto simp: * ** ***)
  qed
  ultimately have "\<forall>i. ?S i \<in> A \<and> P (?S (Suc i)) (?S i)" by blast
  with assms(1) show False
    unfolding wfp_on_def by fast
qed

lemma minimal_imp_inductive_on:
  assumes "\<forall>Q x. x \<in> Q \<and> Q \<subseteq> A \<longrightarrow> (\<exists>z\<in>Q. \<forall>y. P y z \<longrightarrow> y \<notin> Q)"
  shows "inductive_on P A"
proof (rule ccontr)
  assume "\<not> ?thesis"
  then obtain Q x
    where *: "\<forall>y\<in>A. (\<forall>x\<in>A. P x y \<longrightarrow> Q x) \<longrightarrow> Q y"
    and **: "x \<in> A" "\<not> Q x"
    by (auto simp: inductive_on_def)
  let ?Q = "{x\<in>A. \<not> Q x}"
  from ** have "x \<in> ?Q" by auto
  moreover have "?Q \<subseteq> A" by auto
  ultimately obtain z where "z \<in> ?Q"
    and min: "\<forall>y. P y z \<longrightarrow> y \<notin> ?Q"
    using assms [THEN spec [of _ ?Q], THEN spec [of _ x]] by blast
  from \<open>z \<in> ?Q\<close> have "z \<in> A" and "\<not> Q z" by auto
  with * obtain y where "y \<in> A" and "P y z" and "\<not> Q y" by auto
  then have "y \<in> ?Q" by auto
  with \<open>P y z\<close> and min show False by auto
qed

lemmas wfp_on_imp_inductive_on =
  wfp_on_imp_minimal [THEN minimal_imp_inductive_on]

lemma inductive_on_induct [consumes 2, case_names less, induct pred: inductive_on]:
  assumes "inductive_on P A" and "x \<in> A"
    and "\<And>y. \<lbrakk> y \<in> A; \<And>x. \<lbrakk> x \<in> A; P x y \<rbrakk> \<Longrightarrow> Q x \<rbrakk> \<Longrightarrow> Q y"
  shows "Q x"
  using assms unfolding inductive_on_def by metis

lemma inductive_on_imp_wfp_on:
  assumes "inductive_on P A"
  shows "wfp_on P A"
proof -
  let ?Q = "\<lambda>x. \<not> (\<exists>f. f 0 = x \<and> (\<forall>i. f i \<in> A \<and> P (f (Suc i)) (f i)))"
  { fix x assume "x \<in> A"
    with assms have "?Q x"
    proof (induct rule: inductive_on_induct)
      fix y assume "y \<in> A" and IH: "\<And>x. x \<in> A \<Longrightarrow> P x y \<Longrightarrow> ?Q x"
      show "?Q y"
      proof (rule ccontr)
        assume "\<not> ?Q y"
        then obtain f where *: "f 0 = y"
          "\<forall>i. f i \<in> A \<and> P (f (Suc i)) (f i)" by auto
        then have "P (f (Suc 0)) (f 0)" and "f (Suc 0) \<in> A" by auto
        with IH and * have "?Q (f (Suc 0))" by auto
        with * show False by auto
      qed
    qed }
  then show ?thesis unfolding wfp_on_def by blast
qed

definition qo_on :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a set \<Rightarrow> bool" where
  "qo_on P A \<longleftrightarrow> reflp_on A P \<and> transp_on A P"

definition po_on :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a set \<Rightarrow> bool" where
  "po_on P A \<longleftrightarrow> (irreflp_on A P \<and> transp_on A P)"

lemma po_onI [Pure.intro]:
  "\<lbrakk>irreflp_on A P; transp_on A P\<rbrakk> \<Longrightarrow> po_on P A"
  by (auto simp: po_on_def)

lemma po_on_converse_simp [simp]:
  "po_on P\<inverse>\<inverse> A \<longleftrightarrow> po_on P A"
  by (simp add: po_on_def)

lemma po_on_imp_qo_on:
  "po_on P A \<Longrightarrow> qo_on (P\<^sup>=\<^sup>=) A"
  unfolding po_on_def qo_on_def
  by (metis reflp_on_reflclp transp_on_reflclp)

lemma po_on_imp_irreflp_on:
  "po_on P A \<Longrightarrow> irreflp_on A P"
  by (auto simp: po_on_def)

lemma po_on_imp_transp_on:
  "po_on P A \<Longrightarrow> transp_on A P"
  by (auto simp: po_on_def)

lemma po_on_subset:
  assumes "A \<subseteq> B" and "po_on P B"
  shows "po_on P A"
  using transp_on_subset and irreflp_on_subset and assms
  unfolding po_on_def by blast

lemma transp_on_irreflp_on_imp_antisymp_on:
  assumes "transp_on A P" and "irreflp_on A P"
  shows "antisymp_on A (P\<^sup>=\<^sup>=)"
proof (rule antisymp_onI)
  fix a b assume "a \<in> A"
    and "b \<in> A" and "P\<^sup>=\<^sup>= a b" and "P\<^sup>=\<^sup>= b a"
  show "a = b"
  proof (rule ccontr)
    assume "a \<noteq> b"
    with \<open>P\<^sup>=\<^sup>= a b\<close> and \<open>P\<^sup>=\<^sup>= b a\<close> have "P a b" and "P b a" by auto
    with \<open>transp_on A P\<close> and \<open>a \<in> A\<close> and \<open>b \<in> A\<close> have "P a a" unfolding transp_on_def by blast
    with \<open>irreflp_on A P\<close> and \<open>a \<in> A\<close> show False unfolding irreflp_on_def by blast
  qed
qed

lemma po_on_imp_antisymp_on:
  assumes "po_on P A"
  shows "antisymp_on A P"
using transp_on_irreflp_on_imp_antisymp_on [of A P] and assms by (auto simp: po_on_def)

lemma strict_reflclp [simp]:
  assumes "x \<in> A" and "y \<in> A"
    and "transp_on A P" and "irreflp_on A P"
  shows "strict (P\<^sup>=\<^sup>=) x y = P x y"
  using assms unfolding transp_on_def irreflp_on_def
  by blast

lemma qo_on_imp_reflp_on:
  "qo_on P A \<Longrightarrow> reflp_on A P"
  by (auto simp: qo_on_def)

lemma qo_on_imp_transp_on:
  "qo_on P A \<Longrightarrow> transp_on A P"
  by (auto simp: qo_on_def)

lemma qo_on_subset:
  "A \<subseteq> B \<Longrightarrow> qo_on P B \<Longrightarrow> qo_on P A"
  unfolding qo_on_def
  using reflp_on_subset
    and transp_on_subset by blast

text \<open>
  Quasi-orders are instances of the @{class preorder} class.
\<close>
lemma qo_on_UNIV_conv:
  "qo_on P UNIV \<longleftrightarrow> class.preorder P (strict P)" (is "?lhs = ?rhs")
proof
  assume "?lhs" then show "?rhs"
    unfolding qo_on_def class.preorder_def
    using qo_on_imp_reflp_on [of P UNIV]
      and qo_on_imp_transp_on [of P UNIV]
    by (auto simp: reflp_on_def) (unfold transp_on_def, blast)
next
  assume "?rhs" then show "?lhs"
    unfolding class.preorder_def
    by (auto simp: qo_on_def reflp_on_def transp_on_def)
qed

lemma wfp_on_iff_inductive_on:
  "wfp_on P A \<longleftrightarrow> inductive_on P A"
  by (blast intro: inductive_on_imp_wfp_on wfp_on_imp_inductive_on)

lemma wfp_on_iff_minimal:
  "wfp_on P A \<longleftrightarrow> (\<forall>Q x.
     x \<in> Q \<and> Q \<subseteq> A \<longrightarrow>
     (\<exists>z\<in>Q. \<forall>y. P y z \<longrightarrow> y \<notin> Q))"
  using wfp_on_imp_minimal [of P A]
    and minimal_imp_inductive_on [of A P]
    and inductive_on_imp_wfp_on [of P A]
    by blast

text \<open>
  Every non-empty well-founded set @{term A} has a minimal element, i.e., an element that is not
  greater than any other element.
\<close>
lemma wfp_on_imp_has_min_elt:
  assumes "wfp_on P A" and "A \<noteq> {}"
  shows "\<exists>x\<in>A. \<forall>y\<in>A. \<not> P y x"
  using assms unfolding wfp_on_iff_minimal by force

lemma wfp_on_induct [consumes 2, case_names less, induct pred: wfp_on]:
  assumes "wfp_on P A" and "x \<in> A"
    and "\<And>y. \<lbrakk> y \<in> A; \<And>x. \<lbrakk> x \<in> A; P x y \<rbrakk> \<Longrightarrow> Q x \<rbrakk> \<Longrightarrow> Q y"
  shows "Q x"
  using assms and inductive_on_induct [of P A x]
  unfolding wfp_on_iff_inductive_on by blast

lemma wfp_on_UNIV [simp]:
  "wfp_on P UNIV \<longleftrightarrow> wfP P"
  unfolding wfp_on_iff_inductive_on inductive_on_def wfP_def wf_def by force

subsection \<open>Measures on Sets (Instead of Full Types)\<close>

definition
  inv_image_betw ::
    "('b \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'a set \<Rightarrow> 'b set \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> bool)"
where
  "inv_image_betw P f A B = (\<lambda>x y. x \<in> A \<and> y \<in> A \<and> f x \<in> B \<and> f y \<in> B \<and> P (f x) (f y))"

definition
  measure_on :: "('a \<Rightarrow> nat) \<Rightarrow> 'a set \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool"
where
  "measure_on f A = inv_image_betw (<) f A UNIV"

lemma in_inv_image_betw [simp]:
  "inv_image_betw P f A B x y \<longleftrightarrow> x \<in> A \<and> y \<in> A \<and> f x \<in> B \<and> f y \<in> B \<and> P (f x) (f y)"
  by (auto simp: inv_image_betw_def)

lemma in_measure_on [simp, code_unfold]:
  "measure_on f A x y \<longleftrightarrow> x \<in> A \<and> y \<in> A \<and> f x < f y"
  by (simp add: measure_on_def)

lemma wfp_on_inv_image_betw [simp, intro!]:
  assumes "wfp_on P B"
  shows "wfp_on (inv_image_betw P f A B) A" (is "wfp_on ?P A")
proof (rule ccontr)
  assume "\<not> ?thesis"
  then obtain g where "\<forall>i. g i \<in> A \<and> ?P (g (Suc i)) (g i)" by (auto simp: wfp_on_def)
  with assms show False by (auto simp: wfp_on_def)
qed

lemma wfp_less:
  "wfp_on (<) (UNIV :: nat set)"
  using wf_less by (auto simp: wfP_def)

lemma wfp_on_measure_on [iff]:
  "wfp_on (measure_on f A) A"
  unfolding measure_on_def
  by (rule wfp_less [THEN wfp_on_inv_image_betw])

lemma wfp_on_mono:
  "A \<subseteq> B \<Longrightarrow> (\<And>x y. x \<in> A \<Longrightarrow> y \<in> A \<Longrightarrow> P x y \<Longrightarrow> Q x y) \<Longrightarrow> wfp_on Q B \<Longrightarrow> wfp_on P A"
  unfolding wfp_on_def by (metis subsetD)

lemma wfp_on_subset:
  "A \<subseteq> B \<Longrightarrow> wfp_on P B \<Longrightarrow> wfp_on P A"
  using wfp_on_mono by blast

lemma restrict_to_iff [iff]:
  "restrict_to P A x y \<longleftrightarrow> x \<in> A \<and> y \<in> A \<and> P x y"
  by (simp add: restrict_to_def)

lemma wfp_on_restrict_to [simp]:
  "wfp_on (restrict_to P A) A = wfp_on P A"
  by (auto simp: wfp_on_def)

lemma irreflp_on_strict [simp, intro]:
  "irreflp_on A (strict P)"
  by (auto simp: irreflp_on_def)

lemma transp_on_map':
  assumes "transp_on B Q"
    and "g ` A \<subseteq> B"
    and "h ` A \<subseteq> B"
    and "\<And>x. x \<in> A \<Longrightarrow> Q\<^sup>=\<^sup>= (h x) (g x)"
  shows "transp_on A (\<lambda>x y. Q (g x) (h y))"
  using assms unfolding transp_on_def
  by auto (metis imageI subsetD)

lemma transp_on_map:
  assumes "transp_on B Q"
    and "h ` A \<subseteq> B"
  shows "transp_on A (\<lambda>x y. Q (h x) (h y))"
  using transp_on_map' [of B Q h A h, simplified, OF assms] by blast

lemma irreflp_on_map:
  assumes "irreflp_on B Q"
    and "h ` A \<subseteq> B"
  shows "irreflp_on A (\<lambda>x y. Q (h x) (h y))"
  using assms unfolding irreflp_on_def by auto

lemma po_on_map:
  assumes "po_on Q B"
    and "h ` A \<subseteq> B"
  shows "po_on (\<lambda>x y. Q (h x) (h y)) A"
  using assms and transp_on_map and irreflp_on_map
  unfolding po_on_def by auto

lemma chain_transp_on_less:
  assumes "\<forall>i. f i \<in> A \<and> P (f i) (f (Suc i))" and "transp_on A P" and "i < j"
  shows "P (f i) (f j)"
using \<open>i < j\<close>
proof (induct j)
  case 0 then show ?case by simp
next
  case (Suc j)
  show ?case
  proof (cases "i = j")
    case True
    with Suc show ?thesis using assms(1) by simp
  next
    case False
    with Suc have "P (f i) (f j)" by force
    moreover from assms have "P (f j) (f (Suc j))" by auto
    ultimately show ?thesis using assms(1, 2) unfolding transp_on_def by blast
  qed
qed

lemma wfp_on_imp_irreflp_on:
  assumes "wfp_on P A"
  shows "irreflp_on A P"
proof (rule irreflp_onI)
  fix x
  assume "x \<in> A"
  show "\<not> P x x"
  proof
    let ?f = "\<lambda>_. x"
    assume "P x x"
    then have "\<forall>i. P (?f (Suc i)) (?f i)" by blast
    with \<open>x \<in> A\<close> have "\<not> wfp_on P A" by (auto simp: wfp_on_def)
    with assms show False by contradiction
  qed
qed

inductive
  accessible_on :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a set \<Rightarrow> 'a \<Rightarrow> bool"
  for P and A
where
  accessible_onI [Pure.intro]:
    "\<lbrakk>x \<in> A; \<And>y. \<lbrakk>y \<in> A; P y x\<rbrakk> \<Longrightarrow> accessible_on P A y\<rbrakk> \<Longrightarrow> accessible_on P A x"

lemma accessible_on_imp_mem:
  assumes "accessible_on P A a"
  shows "a \<in> A"
  using assms by (induct) auto

lemma accessible_on_induct [consumes 1, induct pred: accessible_on]:
  assumes *: "accessible_on P A a"
    and IH: "\<And>x. \<lbrakk>accessible_on P A x; \<And>y. \<lbrakk>y \<in> A; P y x\<rbrakk> \<Longrightarrow> Q y\<rbrakk> \<Longrightarrow> Q x"
  shows "Q a"
  by (rule * [THEN accessible_on.induct]) (auto intro: IH accessible_onI)

lemma accessible_on_downward:
  "accessible_on P A b \<Longrightarrow> a \<in> A \<Longrightarrow> P a b \<Longrightarrow> accessible_on P A a"
  by (cases rule: accessible_on.cases) fast

lemma accessible_on_restrict_to_downwards:
  assumes "(restrict_to P A)\<^sup>+\<^sup>+ a b" and "accessible_on P A b"
  shows "accessible_on P A a"
  using assms by (induct) (auto dest: accessible_on_imp_mem accessible_on_downward)

lemma accessible_on_imp_inductive_on:
  assumes "\<forall>x\<in>A. accessible_on P A x"
  shows "inductive_on P A"
proof
  fix Q x
  assume "x \<in> A"
    and *: "\<And>y. \<lbrakk>y \<in> A; \<And>x. \<lbrakk>x \<in> A; P x y\<rbrakk> \<Longrightarrow> Q x\<rbrakk> \<Longrightarrow> Q y"
  with assms have "accessible_on P A x" by auto
  then show "Q x"
  proof (induct)
    case (1 z)
    then have "z \<in> A" by (blast dest: accessible_on_imp_mem)
    show ?case by (rule *) fact+
  qed
qed

lemmas accessible_on_imp_wfp_on = accessible_on_imp_inductive_on [THEN inductive_on_imp_wfp_on]

lemma wfp_on_tranclp_imp_wfp_on:
  assumes "wfp_on (P\<^sup>+\<^sup>+) A"
  shows "wfp_on P A"
  by (rule ccontr) (insert assms, auto simp: wfp_on_def)

lemma inductive_on_imp_accessible_on:
  assumes "inductive_on P A"
  shows "\<forall>x\<in>A. accessible_on P A x"
proof
  fix x
  assume "x \<in> A"
  with assms show "accessible_on P A x"
    by (induct) (auto intro: accessible_onI)
qed

lemma inductive_on_accessible_on_conv:
  "inductive_on P A \<longleftrightarrow> (\<forall>x\<in>A. accessible_on P A x)"
  using inductive_on_imp_accessible_on
    and accessible_on_imp_inductive_on
    by blast

lemmas wfp_on_imp_accessible_on =
  wfp_on_imp_inductive_on [THEN inductive_on_imp_accessible_on]

lemma wfp_on_accessible_on_iff:
  "wfp_on P A \<longleftrightarrow> (\<forall>x\<in>A. accessible_on P A x)"
  by (blast dest: wfp_on_imp_accessible_on accessible_on_imp_wfp_on)

lemma accessible_on_tranclp:
  assumes "accessible_on P A x"
  shows "accessible_on ((restrict_to P A)\<^sup>+\<^sup>+) A x"
    (is "accessible_on ?P A x")
  using assms
proof (induct)
  case (1 x)
  then have "x \<in> A" by (blast dest: accessible_on_imp_mem)
  then show ?case
  proof (rule accessible_onI)
    fix y
    assume "y \<in> A"
    assume "?P y x"
    then show "accessible_on ?P A y"
    proof (cases)
      assume "restrict_to P A y x"
      with 1 and \<open>y \<in> A\<close> show ?thesis by blast
    next
      fix z
      assume "?P y z" and "restrict_to P A z x"
      with 1 have "accessible_on ?P A z" by (auto simp: restrict_to_def)
      from accessible_on_downward [OF this \<open>y \<in> A\<close> \<open>?P y z\<close>]
        show ?thesis .
    qed
  qed
qed

lemma wfp_on_restrict_to_tranclp:
  assumes "wfp_on P A"
  shows "wfp_on ((restrict_to P A)\<^sup>+\<^sup>+) A"
  using wfp_on_imp_accessible_on [OF assms]
    and accessible_on_tranclp [of P A]
    and accessible_on_imp_wfp_on [of A "(restrict_to P A)\<^sup>+\<^sup>+"]
    by blast

lemma wfp_on_restrict_to_tranclp':
  assumes "wfp_on (restrict_to P A)\<^sup>+\<^sup>+ A"
  shows "wfp_on P A"
  by (rule ccontr) (insert assms, auto simp: wfp_on_def)

lemma wfp_on_restrict_to_tranclp_wfp_on_conv:
  "wfp_on (restrict_to P A)\<^sup>+\<^sup>+ A \<longleftrightarrow> wfp_on P A"
  using wfp_on_restrict_to_tranclp [of P A]
    and wfp_on_restrict_to_tranclp' [of P A]
    by blast

lemma tranclp_idemp [simp]:
  "(P\<^sup>+\<^sup>+)\<^sup>+\<^sup>+ = P\<^sup>+\<^sup>+" (is "?l = ?r")
proof (intro ext)
  fix x y
  show "?l x y = ?r x y"
  proof
    assume "?l x y" then show "?r x y" by (induct) auto
  next
    assume "?r x y" then show "?l x y" by (induct) auto
  qed
qed

(*TODO: move the following 3 lemmas to Transitive_Closure?*)
lemma stepfun_imp_tranclp:
  assumes "f 0 = x" and "f (Suc n) = z"
    and "\<forall>i\<le>n. P (f i) (f (Suc i))"
  shows "P\<^sup>+\<^sup>+ x z"
  using assms
  by (induct n arbitrary: x z)
     (auto intro: tranclp.trancl_into_trancl)

lemma tranclp_imp_stepfun:
  assumes "P\<^sup>+\<^sup>+ x z"
  shows "\<exists>f n. f 0 = x \<and> f (Suc n) = z \<and> (\<forall>i\<le>n. P (f i) (f (Suc i)))"
    (is "\<exists>f n. ?P x z f n")
  using assms
proof (induct rule: tranclp_induct)
  case (base y)
  let ?f = "(\<lambda>_. y)(0 := x)"
  have "?f 0 = x" and "?f (Suc 0) = y" by auto
  moreover have "\<forall>i\<le>0. P (?f i) (?f (Suc i))"
    using base by auto
  ultimately show ?case by blast
next
  case (step y z)
  then obtain f n where IH: "?P x y f n" by blast
  then have *: "\<forall>i\<le>n. P (f i) (f (Suc i))"
    and [simp]: "f 0 = x" "f (Suc n) = y"
    by auto
  let ?n = "Suc n"
  let ?f = "f(Suc ?n := z)"
  have "?f 0 = x" and "?f (Suc ?n) = z" by auto
  moreover have "\<forall>i\<le>?n. P (?f i) (?f (Suc i))"
    using \<open>P y z\<close> and * by auto
  ultimately show ?case by blast
qed

lemma tranclp_stepfun_conv:
  "P\<^sup>+\<^sup>+ x y \<longleftrightarrow> (\<exists>f n. f 0 = x \<and> f (Suc n) = y \<and> (\<forall>i\<le>n. P (f i) (f (Suc i))))"
  using tranclp_imp_stepfun and stepfun_imp_tranclp by metis

subsection \<open>Facts About Predecessor Sets\<close>

lemma qo_on_predecessor_subset_conv':
  assumes "qo_on P A" and "B \<subseteq> A" and "C \<subseteq> A"
  shows "{x\<in>A. \<exists>y\<in>B. P x y} \<subseteq> {x\<in>A. \<exists>y\<in>C. P x y} \<longleftrightarrow> (\<forall>x\<in>B. \<exists>y\<in>C. P x y)"
  using assms
  by (auto simp: subset_eq qo_on_def reflp_on_def, unfold transp_on_def) metis+

lemma qo_on_predecessor_subset_conv:
  "\<lbrakk>qo_on P A; x \<in> A; y \<in> A\<rbrakk> \<Longrightarrow> {z\<in>A. P z x} \<subseteq> {z\<in>A. P z y} \<longleftrightarrow> P x y"
  using qo_on_predecessor_subset_conv' [of P A "{x}" "{y}"] by simp

lemma po_on_predecessors_eq_conv:
  assumes "po_on P A" and "x \<in> A" and "y \<in> A"
  shows "{z\<in>A. P\<^sup>=\<^sup>= z x} = {z\<in>A. P\<^sup>=\<^sup>= z y} \<longleftrightarrow> x = y"
  using assms(2-)
    and reflp_on_reflclp [of A P]
    and po_on_imp_antisymp_on [OF \<open>po_on P A\<close>]
    unfolding antisymp_on_def reflp_on_def
    by blast

lemma restrict_to_rtranclp:
  assumes "transp_on A P"
    and "x \<in> A" and "y \<in> A"
  shows "(restrict_to P A)\<^sup>*\<^sup>* x y \<longleftrightarrow> P\<^sup>=\<^sup>= x y"
proof -
  { assume "(restrict_to P A)\<^sup>*\<^sup>* x y"
    then have "P\<^sup>=\<^sup>= x y" using assms
      by (induct) (auto, unfold transp_on_def, blast) }
  with assms show ?thesis by auto
qed

lemma reflp_on_restrict_to_rtranclp:
  assumes "reflp_on A P" and "transp_on A P"
    and "x \<in> A" and "y \<in> A"
  shows "(restrict_to P A)\<^sup>*\<^sup>* x y \<longleftrightarrow> P x y"
  unfolding restrict_to_rtranclp [OF assms(2-)]
  unfolding reflp_on_reflclp_simp [OF assms(1, 3-)] ..

end