(*
  File:      Random_Treap.thy
  Authors:   Max Haslbeck
*)
section \<open>Random treaps\<close>
theory Random_Treap
imports
  Probability_Misc
  Treap_Sort_and_BSTs
begin

subsection \<open>Measurability\<close>

text \<open>
  The following lemmas are only relevant for measurability.
\<close>

(* TODO Move *)
lemma tree_sigma_cong:
  assumes "sets M = sets M'"
  shows   "tree_sigma M = tree_sigma M'"
  using sets_eq_imp_space_eq[OF assms] using assms by (simp add: tree_sigma_def)

lemma distr_restrict:
  assumes "sets N = sets L" "sets K \<subseteq> sets M"
          "\<And>X. X \<in> sets K \<Longrightarrow> emeasure M X = emeasure K X"
          "\<And>X. X \<in> sets M \<Longrightarrow> X \<subseteq> space M - space K \<Longrightarrow> emeasure M X = 0"
          "f \<in> M \<rightarrow>\<^sub>M N" "f \<in> K \<rightarrow>\<^sub>M L"
  shows   "distr M N f = distr K L f"
proof (rule measure_eqI)
  fix X assume "X \<in> sets (distr M N f)"
  thus "emeasure (distr M N f) X = emeasure (distr K L f) X"
    using assms(1) by (intro emeasure_distr_restrict assms) simp_all
qed (use assms in auto)
(* END TODO *)

lemma sets_tree_sigma_count_space:
  assumes "countable B"
  shows   "sets (tree_sigma (count_space B)) = Pow (trees B)"
proof (intro equalityI subsetI)
  fix X assume X: "X \<in> Pow (trees B)"
  have "{t} \<in> sets (tree_sigma (count_space B))" if "t \<in> trees B" for t
    using that
  proof (induction t)
    case (2 l r x)
    hence "{\<langle>la, v, ra\<rangle> |la v ra. (v, la, ra) \<in> {x} \<times> {l} \<times> {r}}
               \<in> sets (tree_sigma (count_space B))"
      by (intro Node_in_tree_sigma pair_measureI) auto
    thus ?case by simp
  qed simp_all
  with X have "(\<Union>t\<in>X. {t}) \<in> sets (tree_sigma (count_space B))"
    by (intro sets.countable_UN' countable_subset[OF _ countable_trees[OF assms]]) auto
  also have "(\<Union>t\<in>X. {t}) = X" by blast
  finally show "X \<in> sets (tree_sigma (count_space B))" .
next
  fix X assume "X \<in> sets (tree_sigma (count_space B))"
  from sets.sets_into_space[OF this] show "X \<in> Pow (trees B)"
    by (simp add: space_tree_sigma)
qed

lemma height_primrec: "height = rec_tree 0 (\<lambda>_ _ _ a b. Suc (max a b))"
proof
  fix t :: "'a tree"
  show "height t = rec_tree 0 (\<lambda>_ _ _ a b. Suc (max a b)) t"
    by (induction t) simp_all
qed

lemma ipl_primrec: "ipl = rec_tree 0 (\<lambda>l _ r a b. size l + size r + a + b)"
proof
  fix t :: "'a tree"
  show "ipl t = rec_tree 0 (\<lambda>l _ r a b. size l + size r + a + b) t"
    by (induction t) auto
qed

lemma size_primrec: "size = rec_tree 0 (\<lambda>_ _ _ a b. 1 + a + b)"
proof
  fix t :: "'a tree"
  show "size t = rec_tree 0 (\<lambda>_ _ _ a b. 1 + a + b) t"
    by (induction t) auto
qed

lemma ipl_map_tree[simp]: "ipl (map_tree f t) = ipl t"
by (induction t) auto

lemma set_pmf_random_bst: "finite A \<Longrightarrow> set_pmf (random_bst A) \<subseteq> trees A"
  by (subst random_bst_altdef)
     (auto intro!: bst_of_list_trees simp add: bst_of_list_trees permutations_of_setD)

lemma trees_mono: "A \<subseteq> B \<Longrightarrow> trees A \<subseteq> trees B"
proof
  fix t
  assume "A \<subseteq> B" "t \<in> trees A"
  then show "t \<in> trees B"
    by (induction t) auto
qed

lemma ins_primrec:
  "ins k (p::real) t = rec_tree
    (Node Leaf (k,p) Leaf)
    (\<lambda>l z r l' r'. case z of (k1, p1) \<Rightarrow>
      if k < k1 then
        (case l' of
          Leaf \<Rightarrow> Leaf
        | Node l2 (k2,p2) r2 \<Rightarrow>
            if 0 \<le> p2 - p1 then Node (Node l2 (k2,p2) r2) (k1,p1) r
            else Node l2 (k2,p2) (Node r2 (k1,p1) r))
      else if k > k1 then
        (case r' of
          Leaf \<Rightarrow> Leaf
        | Node l2 (k2,p2) r2 \<Rightarrow>
            if 0 \<le> p2 - p1 then Node l (k1,p1) (Node l2 (k2,p2) r2)
            else Node (Node l (k1,p1) l2) (k2,p2) r2)
      else Node l (k1,p1) r
      ) t"
proof (induction k p t rule: ins.induct)
  case (2 k p l k1 p1 r)
  thus ?case
    by (cases "k < k1") (auto simp add: case_prod_beta ins_neq_Leaf split: tree.splits if_splits)
qed auto

lemma measurable_ins [measurable (raw)]:
  assumes [measurable]: "countable A"
  assumes [measurable]: "k \<in> B \<rightarrow>\<^sub>M count_space A"
  assumes [measurable]: "x \<in> B \<rightarrow>\<^sub>M (lborel :: real measure)"
  assumes [measurable]: "t \<in> B \<rightarrow>\<^sub>M tree_sigma (count_space A \<Otimes>\<^sub>M lborel)"
  shows   "(\<lambda>y. ins (k y) (x y) (t y)) \<in> B \<rightarrow>\<^sub>M tree_sigma (count_space A \<Otimes>\<^sub>M lborel)"
  unfolding ins_primrec by measurable

lemma map_tree_primrec: "map_tree f t = rec_tree \<langle>\<rangle> (\<lambda>l a r l' r'.  \<langle>l', f a, r'\<rangle>) t"
  by (induction t) auto

definition \<U> where "\<U> = (\<lambda>a b::real. uniform_measure lborel {a..b})"

declare \<U>_def[simp]

fun insR:: "'a::linorder \<Rightarrow> ('a \<times> real) tree \<Rightarrow> 'a set \<Rightarrow> ('a \<times> real) tree measure" where
  "insR x t A  = distr (\<U> 0 1) (tree_sigma (count_space A \<Otimes>\<^sub>M lborel)) (\<lambda>p. ins x p t)"

fun rinss :: "'a::linorder list \<Rightarrow> ('a \<times> real) tree \<Rightarrow> 'a set \<Rightarrow> ('a \<times> real) tree measure" where
  "rinss [] t A =  return (tree_sigma (count_space A \<Otimes>\<^sub>M lborel)) t" |
  "rinss (x#xs) t A = insR x t A \<bind> (\<lambda>t. rinss xs t A)"

lemma sets_rinss':
  assumes "countable B" "set ys \<subseteq> B"
  shows "t \<in> trees (B \<times> UNIV) \<Longrightarrow> sets (rinss ys t B) = sets (tree_sigma (count_space B \<Otimes>\<^sub>M lborel))"
  using assms proof(induction ys arbitrary: t)
  case (Cons y ys)
  then show ?case
    by (subst rinss.simps, subst sets_bind) (auto simp add: space_tree_sigma space_pair_measure)
qed auto

lemma measurable_foldl [measurable]:
  assumes "f \<in> A \<rightarrow>\<^sub>M B" "set xs \<subseteq> space C"
  assumes "\<And>c. c \<in> set xs \<Longrightarrow> (\<lambda>(a,b). g a b c) \<in> (A \<Otimes>\<^sub>M B) \<rightarrow>\<^sub>M B"
  shows   "(\<lambda>x. foldl (g x) (f x) xs) \<in> A \<rightarrow>\<^sub>M B"
  using assms
proof (induction xs arbitrary: f)
  case Nil
  thus ?case by simp
next
  case (Cons x xs)
  note [measurable] = Cons.prems(1)
  from Cons.prems have [measurable]: "x \<in> space C" by simp
  have "(\<lambda>a. (a, f a)) \<in> A \<rightarrow>\<^sub>M A \<Otimes>\<^sub>M B"
    by measurable
  hence "(\<lambda>(a,b). g a b x) \<circ> (\<lambda>a. (a, f a)) \<in> A \<rightarrow>\<^sub>M B"
    by (rule measurable_comp) (rule Cons.prems, auto)
  hence "(\<lambda>a. g a (f a) x) \<in> A \<rightarrow>\<^sub>M B" by (simp add: o_def)
  hence "(\<lambda>xa. foldl (g xa) (g xa (f xa) x) xs) \<in> A \<rightarrow>\<^sub>M B"
    by (rule Cons.IH) (use Cons.prems in auto)
  thus ?case by simp
qed

lemma ins_trees: "t \<in> trees A \<Longrightarrow> (x,y) \<in> A \<Longrightarrow> ins x y t \<in> trees A"
  by (induction x y t rule: ins.induct)
     (auto split: tree.splits simp: ins_neq_Leaf)

subsection \<open>Main result\<close>

text \<open>
  In our setting, we have some countable set of values that may appear in the input and
  a concrete list consisting only of those elements with no repeated elements.

  We further define an abbreviation for the uniform distribution of permutations of that lists.
\<close>

context
  fixes xs::"'a::linorder list" and A::"'a set" and random_perm :: "'a list \<Rightarrow> 'a list measure"
  assumes con_assms: "countable A" "set xs \<subseteq> A" "distinct xs"
  defines "random_perm \<equiv> (\<lambda>xs. uniform_measure (count_space (permutations_of_set (set xs)))
                                 (permutations_of_set (set xs)))"
begin

text \<open>
  Again, we first need some facts about measurability.
\<close>
lemma sets_rinss [simp]:
  assumes "t \<in> trees (A \<times> UNIV)"
  shows "sets (rinss xs t A) = tree_sigma (count_space A \<Otimes>\<^sub>M borel)"
proof -
  have "tree_sigma (count_space A \<Otimes>\<^sub>M (lborel::real measure)) = tree_sigma (count_space A \<Otimes>\<^sub>M borel)"
    by (intro tree_sigma_cong sets_pair_measure_cong) auto
  then show ?thesis
    using assms con_assms by (subst sets_rinss') auto
qed

lemma bst_of_list_measurable [measurable]:
  "bst_of_list \<in> measurable (count_space (lists A)) (tree_sigma (count_space A))"
  by (subst measurable_count_space_eq1)
    (auto simp: space_tree_sigma intro!: bst_of_list_trees)

lemma insort_wrt_measurable [measurable]:
  "(\<lambda>x. insort_wrt x xs) \<in> count_space (Pow (A \<times> A)) \<rightarrow>\<^sub>M count_space (lists A)"
  using con_assms by auto

lemma bst_of_list_sort_meaurable [measurable]:
  "(\<lambda>x. bst_of_list (sort_key x xs)) \<in>
     Pi\<^sub>M (set xs) (\<lambda>i. borel::real measure) \<rightarrow>\<^sub>M tree_sigma (count_space A)"
proof -
  note measurable_linorder_from_keys_restrict'[measurable]
  have "(0::real) < 1"
    by auto
  then have [measurable]: "(\<lambda>x. bst_of_list (insort_wrt (linorder_from_keys (set xs) x) xs))
                      \<in> Pi\<^sub>M (set xs) (\<lambda>i. borel :: real measure) \<rightarrow>\<^sub>M tree_sigma (count_space A)"
    using con_assms by measurable
  show ?thesis
    by (subst insort_wrt_sort_key[symmetric]) (measurable, auto)
qed

text \<open>
  In a first step, we convert the bulk insertion operation to first choosing the
  priorities i.\,i.\,d.\ ahead of time and then inserting all the elements deterministically
  with their associated priority.
\<close>
lemma random_treap_fold:
  assumes "t \<in> space (tree_sigma (count_space A \<Otimes>\<^sub>M lborel))"
  shows "rinss xs t A = distr (\<Pi>\<^sub>M x\<in>set xs. \<U> 0 1)
                              (tree_sigma (count_space A \<Otimes>\<^sub>M lborel))
                              (\<lambda>p. foldl (\<lambda>t x. ins x (p x) t) t xs)"
proof -
  let ?U = "uniform_measure lborel {0::real..1}"
  have "set xs \<subseteq> space (count_space A)" "c \<in> set xs \<Longrightarrow> c \<in> space (count_space A)" for c
    using con_assms by auto
  then have *[intro]: "(\<lambda>p. foldl (\<lambda>t x. ins x (p x) t) t xs) \<in>
    Pi\<^sub>M (set xs) (\<lambda>x. ?U) \<rightarrow>\<^sub>M tree_sigma (count_space A \<Otimes>\<^sub>M lborel)"
    if "t \<in> space (tree_sigma (count_space A \<Otimes>\<^sub>M lborel))" for t
   using that con_assms by measurable
  have insR':
    "insR x t A = ?U \<bind> (\<lambda>u. return (tree_sigma (count_space A \<Otimes>\<^sub>M lborel)) (ins x u t))"
    if "x \<in> A" "t \<in> space (tree_sigma (count_space A \<Otimes>\<^sub>M lborel))" for t x
    using con_assms assms that by (auto simp add: bind_return_distr' \<U>_def)
  have "rinss xs t A = (\<Pi>\<^sub>M x\<in>set xs. ?U) \<bind>
     (\<lambda>p. return (tree_sigma (count_space A \<Otimes>\<^sub>M lborel)) (foldl (\<lambda>t x. ins x (p x) t) t xs))"
    using con_assms(2,3) assms proof (induction xs arbitrary: t)
  case Nil
  then show ?case
    by (intro measure_eqI) (auto simp add: space_PiM_empty emeasure_distr bind_return_distr')
next
  case (Cons x xs)
  note insR.simps[simp del]
  let ?treap_sigma  = "tree_sigma (count_space A \<Otimes>\<^sub>M lborel)"
  have [measurable]: "set xs \<subseteq> space (count_space A)" "x \<in> A"
                     "c \<in> A \<Longrightarrow> c \<in> space (count_space A)" for c
    using Cons by auto
  have [intro!]: "ins k p t \<in> space ?treap_sigma" if "t \<in> space ?treap_sigma" "k \<in> A"
    for k t and p::real
    using that
    by (auto intro!: ins_trees simp add: space_tree_sigma space_pair_measure)
  have [measurable]: "Pi\<^sub>M (set xs) (\<lambda>x. ?U) \<in> space (prob_algebra (Pi\<^sub>M (set xs) (\<lambda>i. ?U)))"
    unfolding space_prob_algebra by (auto intro!: prob_space_uniform_measure prob_space_PiM)
  have [measurable]: "Pi\<^sub>M (set xs) (\<lambda>x. ?U) \<in> space (subprob_algebra (Pi\<^sub>M (set xs) (\<lambda>i. ?U)))"
    unfolding space_subprob_algebra
    by (auto intro!: prob_space_imp_subprob_space prob_space_uniform_measure prob_space_PiM)
  have [measurable]: "(\<lambda>x. x) \<in> (?treap_sigma \<Otimes>\<^sub>M Pi\<^sub>M (set xs) (\<lambda>i. ?U)) \<Otimes>\<^sub>M ?treap_sigma \<rightarrow>\<^sub>M
            (?treap_sigma \<Otimes>\<^sub>M Pi\<^sub>M (set xs) (\<lambda>i. borel)) \<Otimes>\<^sub>M ?treap_sigma"
    by (auto intro!: measurable_ident_sets sets_pair_measure_cong sets_PiM_cong simp add: \<U>_def)
  have [simp]: "(\<lambda>w. Pi\<^sub>M (set xs) (\<lambda>x. ?U) \<bind>
        (\<lambda>p. return ?treap_sigma (foldl (\<lambda>t x. ins x (p x) t) w xs)))
        \<in> ?treap_sigma \<rightarrow>\<^sub>M subprob_algebra ?treap_sigma"
  proof -
    have [measurable]: "c \<in> set xs \<Longrightarrow> c \<in> A" for c
      using Cons by auto
    show ?thesis
      using con_assms by measurable
  qed
  have [measurable]: "?U \<in> space (prob_algebra (?U))"
    by (simp add: prob_space_uniform_measure space_prob_algebra)
  have [measurable, intro]: "(\<lambda>t. rinss xs t A) \<in> ?treap_sigma \<rightarrow>\<^sub>M subprob_algebra ?treap_sigma"
    if "set xs \<subseteq> A" for xs
    using that proof (induction xs)
    case (Cons x xs)
    then have [measurable]: "x \<in> A" "set xs \<subseteq> A"
      by auto
    have [measurable]: "(\<lambda>y. x) \<in> tree_sigma (count_space A \<Otimes>\<^sub>M lborel) \<Otimes>\<^sub>M ?U \<rightarrow>\<^sub>M count_space A"
      using Cons by measurable
    have [measurable]: "(\<lambda>x. x) \<in> ?treap_sigma \<Otimes>\<^sub>M ?U \<rightarrow>\<^sub>M ?treap_sigma \<Otimes>\<^sub>M borel"
      unfolding \<U>_def by auto
    have [measurable]: "(\<lambda>t. distr (?U) (tree_sigma (count_space A \<Otimes>\<^sub>M lborel)) (\<lambda>p. ins x p t))
    \<in> ?treap_sigma \<rightarrow>\<^sub>M subprob_algebra ?treap_sigma"
      using con_assms by (intro measurable_prob_algebraD) measurable
    from Cons show ?case
      unfolding rinss.simps insR.simps \<U>_def by measurable
  qed auto
  have [intro]: "(\<lambda>u. return ?treap_sigma (ins x u t)) \<in> ?U \<rightarrow>\<^sub>M subprob_algebra ?treap_sigma"
    using con_assms Cons by measurable
  have [simp]: "space (?U \<Otimes>\<^sub>M Pi\<^sub>M (set xs) (\<lambda>x. ?U)) \<noteq> {}"
    by (simp add: prob_space.not_empty prob_space_PiM prob_space_pair prob_space_uniform_measure)
  from Cons have "rinss (x # xs) t A = (?U \<bind>
                                       (\<lambda>u. return ?treap_sigma (ins x u t))) \<bind>
                                       (\<lambda>t. rinss xs t A)"
    by (simp add: insR')
  also have "\<dots> = ?U \<bind> (\<lambda>u. return ?treap_sigma (ins x u t) \<bind> (\<lambda>t. rinss xs t A))"
    using con_assms Cons by (subst bind_assoc) auto
  also have "\<dots> = ?U \<bind> (\<lambda>u. rinss xs (ins x u t) A)"
    using con_assms Cons by (subst bind_return) auto
  also have "\<dots> = ?U \<bind>
                 (\<lambda>u. Pi\<^sub>M (set xs) (\<lambda>x. ?U) \<bind>
                 (\<lambda>p. return ?treap_sigma (foldl (\<lambda>t x. ins x (p x) t) (ins x u t) xs)))"
    using Cons by (subst Cons) (auto simp add: treap_ins keys_ins)
  also have "\<dots> = ?U \<Otimes>\<^sub>M Pi\<^sub>M (set xs) (\<lambda>x. ?U) \<bind>
                  (\<lambda>(u,p). return ?treap_sigma (foldl (\<lambda>t x. ins x (p x) t) (ins x u t) xs))"
  proof -
    have [measurable]: "pair_prob_space (?U) (Pi\<^sub>M (set xs) (\<lambda>x. ?U))"
      by (simp add: \<U>_def pair_prob_space_def pair_sigma_finite.intro prob_space_PiM
          prob_space_imp_sigma_finite prob_space_uniform_measure)
    note this[unfolded \<U>_def, measurable]
    have [measurable]: "c \<in> set xs \<Longrightarrow> c \<in> A" for c
      using Cons by auto
    show ?thesis
      using con_assms Cons by (subst pair_prob_space.pair_measure_bind) measurable
  qed
  also have "\<dots> = distr (?U \<Otimes>\<^sub>M Pi\<^sub>M (set xs) (\<lambda>x. ?U)) (tree_sigma (count_space A \<Otimes>\<^sub>M lborel))
                  (\<lambda>(u, f). foldl (\<lambda>t x. ins x (f x) t) (ins x u t) xs)"
  proof -
    have [simp]: "c \<in> set xs \<Longrightarrow> c \<in> A" for c
      using Cons by auto
    have "(\<lambda>xa. foldl (\<lambda>t x. ins x (snd xa x) t) (ins x (fst xa) t) xs) =
          (\<lambda>(u, f). foldl (\<lambda>t x. ins x (f x) t) (ins x u t) xs)"
      by (auto simp add: case_prod_beta')
    then show ?thesis
      using con_assms Cons by (subst case_prod_beta', subst bind_return_distr') measurable
  qed
  also have
    "\<dots> = distr (?U \<Otimes>\<^sub>M Pi\<^sub>M (set xs) (\<lambda>i. ?U)) ?treap_sigma
          (\<lambda>f. foldl (\<lambda>t y. ins y (if y = x then fst f else snd f y) t) (ins x (fst f) t) xs)"
  proof -
    have "foldl (\<lambda>t y. ins y (snd f y) t) (ins x (fst f) t) xs =
          foldl (\<lambda>t y. ins y (if y = x then fst f else snd f y) t) (ins x (fst f) t) xs" for f
      using Cons by (intro foldl_cong) auto
    then show ?thesis
      by (auto simp add: case_prod_beta')
  qed
  also have "\<dots> = distr (?U \<Otimes>\<^sub>M Pi\<^sub>M (set xs) (\<lambda>i. ?U)) (Pi\<^sub>M (insert x (set xs)) (\<lambda>i. ?U))
                          (\<lambda>(r, f). f(x := r)) \<bind>
                          (\<lambda>p. return ?treap_sigma (foldl (\<lambda>t x. ins x (p x) t) (ins x (p x) t) xs))"
    using con_assms  Cons
    by (subst bind_distr_return) (measurable, auto simp add: case_prod_beta')
  also have "\<dots> = Pi\<^sub>M (insert x (set xs)) (\<lambda>x. ?U) \<bind>
                  (\<lambda>p. return ?treap_sigma (foldl (\<lambda>t x. ins x (p x) t) (ins x (p x) t) xs))"
    by (subst distr_pair_PiM_eq_PiM) (auto simp add: prob_space_uniform_measure)
  finally show ?case
    by (simp)
qed
  then show ?thesis
    using assms by (subst bind_return_distr'[symmetric]) (auto simp add: bind_return_distr')
qed

corollary random_treap_fold_Leaf:
  shows "rinss xs Leaf A =
         distr (\<Pi>\<^sub>M x\<in>set xs. \<U> 0 1)
               (tree_sigma (count_space A \<Otimes>\<^sub>M lborel))
               (\<lambda>p. foldl (\<lambda>t x. ins x (p x) t) Leaf xs)"
  by (auto simp add: random_treap_fold)

text \<open>
  Next, we show that additionally forgetting the priorities in the end will yield
  the same distribution as inserting the elements into a BST by ascending priority.
\<close>
lemma rinss_bst_of_list:
      "distr (rinss xs Leaf A) (tree_sigma (count_space A)) (map_tree fst) =
       distr (Pi\<^sub>M (set xs) (\<lambda>x. \<U> 0 1)) (tree_sigma (count_space A))
             (\<lambda>p. bst_of_list (sort_key p xs))" (is "?lhs = ?rhs")
proof -
  have [measurable]: "set xs \<subseteq> space (count_space A)"
    "c \<in> set xs \<Longrightarrow> c \<in> space (count_space A)" for c
    using con_assms by auto
  have [simp]: "map_tree fst \<circ> (\<lambda>p. foldl (\<lambda>t x. ins x (p x) t) \<langle>\<rangle> xs)
                \<in> Pi\<^sub>M (set xs) (\<lambda>x. uniform_measure lborel {0::real..1}) \<rightarrow>\<^sub>M
                  tree_sigma (count_space A)"
    unfolding \<U>_def map_tree_primrec using con_assms by measurable
  have "AE f in Pi\<^sub>M (set xs) (\<lambda>i. \<U> 0 1). inj_on f (set xs)"
    unfolding \<U>_def by (rule almost_everywhere_avoid_finite) auto
  then have "AE f in Pi\<^sub>M (set xs) (\<lambda>x. \<U> 0 1).
             map_tree fst (foldl (\<lambda>t (k,p). ins k p t) \<langle>\<rangle> (map (\<lambda>x. (x, f x)) xs)) =
             bst_of_list (sort_key f xs)"
    by (eventually_elim) (use con_assms in \<open>auto simp add: fold_ins_bst_of_list\<close>)
  then have [simp]: "AE f in Pi\<^sub>M (set xs) (\<lambda>x. \<U> 0 1).
             map_tree fst (foldl (\<lambda>t k. ins k (f k) t) \<langle>\<rangle> xs) = bst_of_list (sort_key f xs)"
    by (simp add: foldl_map)
  have "?lhs = distr (Pi\<^sub>M (set xs) (\<lambda>x. \<U> 0 1)) (tree_sigma (count_space A))
                     (map_tree fst \<circ> (\<lambda>p. foldl (\<lambda>t x. ins x (p x) t) \<langle>\<rangle> xs))"
    unfolding random_treap_fold_Leaf \<U>_def map_tree_primrec using con_assms
    by (subst distr_distr) measurable
  also have "\<dots> = ?rhs"
    by (intro distr_cong_AE) (auto simp add: \<U>_def)
  finally show ?thesis .
qed

text \<open>
  This in turn is the same as choosing a random permutation of the input list and
  inserting the elements into a BST in that order.
\<close>
lemma lborel_permutations_of_set_bst_of_list:
  shows "distr (Pi\<^sub>M (set xs) (\<lambda>x. \<U> 0 1)) (tree_sigma (count_space A))
               (\<lambda>p. bst_of_list (sort_key p xs)) =
         distr (random_perm xs) (tree_sigma (count_space A)) bst_of_list" (is "?lhs = ?rhs")
proof -
  have [measurable]: "(0::real) < 1"
    by auto
  have "insort_wrt R xs = insort_wrt R (remdups xs)" for R
    using con_assms distinct_remdups_id by metis
  then have *: "insort_wrt R xs = sorted_wrt_list_of_set R (set xs)"
    if "linorder_on (set xs) R" for R
    using that by (subst sorted_wrt_list_set) auto
  have [measurable]: "(\<lambda>x. x) \<in> count_space (permutations_of_set (set xs)) \<rightarrow>\<^sub>M count_space (lists A)"
    using con_assms permutations_of_setD by fastforce
  have [measurable]: "(\<lambda>R. insort_wrt R xs) \<in>
                      count_space (Pow (A \<times> A)) \<rightarrow>\<^sub>M count_space (permutations_of_set (set xs))"
    using con_assms by (simp add: permutations_of_setI)
  have "?lhs
   = distr (Pi\<^sub>M (set xs) (\<lambda>x. \<U> 0 1)) (tree_sigma (count_space A))
           (\<lambda>p. bst_of_list (insort_wrt (linorder_from_keys (set xs) p) xs))"
    unfolding Let_def by (simp add: insort_wrt_sort_key)
 also have "\<dots> =
  distr (distr (Pi\<^sub>M (set xs) (\<lambda>x. uniform_measure lborel {0::real..1}))
    (count_space (Pow (A \<times> A))) (linorder_from_keys (set xs)))
  (tree_sigma (count_space A)) (\<lambda>R. bst_of_list (insort_wrt R xs))"
   unfolding \<U>_def using con_assms by (subst distr_distr) (measurable, metis comp_apply)
  also have "\<dots> =
  distr (uniform_measure (count_space (Pow (A \<times> A))) (linorders_on (set xs)))
        (tree_sigma (count_space A)) (\<lambda>R. bst_of_list (insort_wrt R xs))"
    using con_assms by (subst random_linorder_by_prios) auto
  also have "\<dots> = distr (distr (uniform_measure (count_space (Pow (A \<times> A))) (linorders_on (set xs)))
                               (count_space (permutations_of_set (set xs))) (\<lambda>R. insort_wrt R xs))
                        (tree_sigma (count_space A)) bst_of_list"
    by (subst distr_distr) (measurable, metis comp_apply)
  also have "\<dots> = distr (uniform_measure (count_space (permutations_of_set (set xs)))
                          ((\<lambda>R. insort_wrt R xs) ` linorders_on (set xs)))
                    (tree_sigma (count_space A)) bst_of_list"
  proof -
    have "bij_betw (\<lambda>R. insort_wrt R xs) (linorders_on (set xs)) (permutations_of_set (set xs))"
      by (subst bij_betw_cong, fastforce simp add: * linorders_on_def bij_betw_cong)
         (use bij_betw_linorders_on' in blast)
    then have "inj_on (\<lambda>R. insort_wrt R xs) (linorders_on (set xs))"
      by (rule bij_betw_imp_inj_on)
    then have "distr (uniform_measure (count_space (Pow (A \<times> A))) (linorders_on (set xs)))
                     (count_space (permutations_of_set (set xs))) (\<lambda>R. insort_wrt R xs)
               = uniform_measure (count_space (permutations_of_set (set xs)))
                                 ((\<lambda>R. insort_wrt R xs) ` linorders_on (set xs))"
      using con_assms by (intro distr_uniform_measure_count_space_inj)
        (auto simp add: linorders_on_def linorder_on_def refl_on_def)
    then show ?thesis by auto
  qed
  also have "\<dots> = distr (random_perm xs) (tree_sigma (count_space A)) bst_of_list"
  proof -
    have "((\<lambda>R. insort_wrt R xs) ` linorders_on (set xs)) = permutations_of_set (set xs)"
      by (intro bij_betw_imp_surj_on, subst bij_betw_cong, rule *)
         (fastforce simp add: linorders_on_def,  use bij_betw_linorders_on' in blast)
   then show ?thesis by (simp add: random_perm_def)
 qed
  finally show ?thesis .
qed

lemma distr_bst_of_list_tree_sigma_count_space: "
   distr (random_perm xs) (tree_sigma (count_space A)) bst_of_list =
     distr (random_perm xs) (count_space (trees A)) bst_of_list"
  using con_assms by (intro distr_cong)  (auto intro!: sets_tree_sigma_count_space)

text \<open>
  This is the same as a \emph{random BST}.
\<close>
lemma distr_bst_of_list_random_bst: "
  distr (random_perm xs) (count_space (trees A)) bst_of_list =
    restrict_space (random_bst (set xs)) (trees A)" (is "?lhs = ?rhs")
proof -
  have "?rhs = restrict_space (distr (uniform_measure (count_space UNIV)
                 (permutations_of_set (set xs))) (count_space UNIV) bst_of_list) (trees A)"
    by (auto simp: random_bst_altdef measure_pmf_of_set map_pmf_rep_eq)
  also have "distr (uniform_measure (count_space UNIV) (permutations_of_set (set xs)))
                   (count_space UNIV) bst_of_list =
               distr (random_perm xs) (count_space UNIV) bst_of_list"
    by (intro distr_restrict) (auto simp: random_perm_def)
  also have "restrict_space \<dots> (trees A) =
               distr (random_perm xs) (count_space (trees A)) bst_of_list"
    using con_assms
    by (subst restrict_distr)
       (auto simp: random_perm_def bst_of_list_trees restrict_count_space permutations_of_setD)
  finally show ?thesis ..
qed

text \<open>
  We put everything together and obtain our main result:
\<close>
theorem rinss_random_bst:
  "distr (rinss xs \<langle>\<rangle> A) (tree_sigma (count_space A)) (map_tree fst) =
     restrict_space (measure_pmf (random_bst (set xs))) (trees A)"
  by (simp only: rinss_bst_of_list lborel_permutations_of_set_bst_of_list
                 distr_bst_of_list_tree_sigma_count_space distr_bst_of_list_random_bst)

end
end


theory SomeCategoryTheory
  imports Main
         "Category3.Subcategory"
         "Category3.NaturalTransformation"
         "Category3.ProductCategory"
         "Category3.AbstractedCategory"
         "Category3.FunctorCategory"
begin

lemma (in category) in_hom_dom : "\<guillemotleft> f : a \<rightarrow> b \<guillemotright> \<Longrightarrow> dom f = a"
  by blast
lemma (in category) in_hom_cod : "\<guillemotleft> f : a \<rightarrow> b \<guillemotright> \<Longrightarrow> cod f = b"
  by blast

lemma transport : "x \<in> A \<Longrightarrow> A = B \<Longrightarrow> x \<in> B"
  by simp

lemma (in natural_transformation) preserves_arr :
  assumes "A.arr f"
  shows "B.arr (\<tau> f)"
  using \<open>A.arr f\<close>
  unfolding preserves_reflects_arr.

lemma reverse_equality : "a = b \<Longrightarrow> b = a"
  by simp

fun MkFunctor :: "'a comp \<Rightarrow> 'b comp \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b" where
  "MkFunctor C D f a =
                 (if partial_magma.arr C a
                 then f a
                 else partial_magma.null D)"

lemma (in category) seq_ide_arr : "ide a \<Longrightarrow> arr f \<Longrightarrow> cod f = a \<Longrightarrow> seq a f"
  apply (rule_tac seqI')
  by auto

locale binary_product =
  C : category C
  for C :: "'c comp"
  and factor1 factor2 :: "'c"
  and prod :: "'c"
  and proj1 proj2 :: "'c"
  and UP_map :: "'c \<Rightarrow> 'c \<Rightarrow> 'c" +
assumes factor1_obj : "C.ide factor1"
  and factor2_obj : "C.ide factor2"
  and prod_obj : "C.ide prod"
  and proj1_in_hom : "C.in_hom proj1 prod factor1"
  and proj2_in_hom : "C.in_hom proj2 prod factor2"
  and UP_existence : "\<And>f g. C.arr f \<Longrightarrow> C.arr g \<Longrightarrow> C.dom f = C.dom g \<Longrightarrow>
                      C.cod f = factor1 \<Longrightarrow> C.cod g = factor2 \<Longrightarrow>
             C.in_hom (UP_map f g) (C.dom f) prod \<and>
                (C proj1 (UP_map f g) = f \<and>
                C proj2 (UP_map f g) = g)"
  and   UP_uniqueness: "\<And>f g. C.arr f \<Longrightarrow> C.arr g \<Longrightarrow> C.dom f = C.dom g \<Longrightarrow>
                      C.cod f = factor1 \<Longrightarrow> C.cod g = factor2 \<Longrightarrow>
                       (\<And>h. C.in_hom h (C.dom f) prod \<and>
                             (C proj1 h = f \<and>
                              C proj2 h = g)
                         \<Longrightarrow> h = UP_map f g)"
begin
end

locale category_with_products =
  C : category C
  for C :: "'c comp"
  and prod :: "'c \<Rightarrow> 'c \<Rightarrow> 'c"
  and proj1 :: "'c \<Rightarrow> 'c \<Rightarrow> 'c"
  and proj2 :: "'c \<Rightarrow> 'c \<Rightarrow> 'c"
  and UP_map :: "'c \<Rightarrow> 'c \<Rightarrow> 'c" +
assumes product_existence : "\<And> a b. C.ide a \<Longrightarrow> C.ide b \<Longrightarrow>
        binary_product C a b (prod a b) (proj1 a b) (proj2 a b) UP_map"
begin

lemma prod_obj: "\<And>a b. C.ide a \<Longrightarrow> C.ide b \<Longrightarrow> C.ide (prod a b)"
  using binary_product.prod_obj [OF product_existence].

lemma proj1_in_hom : "\<And>a b. C.ide a \<Longrightarrow> C.ide b \<Longrightarrow> C.in_hom (proj1 a b) (prod a b) a"
  using binary_product.proj1_in_hom [OF product_existence].

lemma proj2_in_hom : "\<And>a b. C.ide a \<Longrightarrow> C.ide b \<Longrightarrow> C.in_hom (proj2 a b) (prod a b) b"
  using binary_product.proj2_in_hom [OF product_existence].

lemma UP_existence : "\<And>f g. C.arr f \<Longrightarrow> C.arr g \<Longrightarrow> C.dom f = C.dom g \<Longrightarrow>
                      C.in_hom (UP_map f g) (C.dom f) (prod (C.cod f) (C.cod g)) \<and>
                      (C (proj1 (C.cod f) (C.cod g)) (UP_map f g) = f \<and>
                       C (proj2 (C.cod f) (C.cod g)) (UP_map f g) = g)"
  using binary_product.UP_existence [OF product_existence
        [OF C.ide_cod C.ide_cod]]
  by simp

lemma UP_uniqueness: "\<And>f g. C.arr f \<Longrightarrow> C.arr g \<Longrightarrow> C.dom f = C.dom g \<Longrightarrow>
               (\<And>h. C.in_hom h (C.dom f) (prod (C.cod f) (C.cod g)) \<and>
                (C (proj1 (C.cod f) (C.cod g)) h = f \<and>
                 C (proj2 (C.cod f) (C.cod g)) h = g)
                 \<Longrightarrow> h = UP_map f g)"
  using binary_product.UP_uniqueness [OF product_existence
        [OF C.ide_cod C.ide_cod]]
  by simp

definition prod_functor :: "'c \<times> 'c \<Rightarrow> 'c" where
  "prod_functor = MkFunctor (product_category.comp C C) C
                  (\<lambda> (f, g). UP_map
                  (C f (proj1 (C.dom f) (C.dom g)))
                  (C g (proj2 (C.dom f) (C.dom g))))"

interpretation CxC : product_category C C
  unfolding product_category_def
  by (simp_all add: C.category_axioms)

lemma prod_functor : "functor (product_category.comp C C) C prod_functor"
  unfolding functor_def
  apply (simp add: C.category_axioms CxC.category_axioms)
  unfolding functor_axioms_def
  apply (subst prod_functor_def)
  apply simp
  apply safe
proof-
  fix a b
  assume arr_a :"C.arr a"
  assume arr_b :"C.arr b"

  have proj1_prop : "\<guillemotleft>proj1 (C.dom a) (C.dom b) : prod (C.dom a) (C.dom b) \<rightarrow> C.dom a\<guillemotright>"
    using proj1_in_hom [OF C.ide_dom [OF arr_a]
                           C.ide_dom [OF arr_b]].
  have proj2_prop : "\<guillemotleft>proj2 (C.dom a) (C.dom b) : prod (C.dom a) (C.dom b) \<rightarrow> C.dom b\<guillemotright>"
    using proj2_in_hom [OF C.ide_dom [OF arr_a]
                           C.ide_dom [OF arr_b]].

  define a1 where "a1 = (C a (proj1 (C.dom a) (C.dom b)))"
  have arr_a1 : "C.arr a1"
    unfolding a1_def
    apply (rule_tac C.seqI')
    using proj1_prop apply simp
    using C.in_homI [OF arr_a] by blast

  define b2 where "b2 = (C b (proj2 (C.dom a) (C.dom b)))"
  have arr_b2 : "C.arr b2"
    unfolding b2_def
    apply (rule_tac C.seqI')
    using proj2_prop apply simp
    using C.in_homI [OF arr_b] by blast

  have proj_dom_eq : "C.dom (proj1 (C.dom a) (C.dom b)) = C.dom (proj2 (C.dom a) (C.dom b))"
    apply (rule_tac C.in_homE [OF proj1_prop])
    apply (rule_tac C.in_homE [OF proj2_prop])
    by simp

  have UP_prop : "C.in_hom (UP_map a1 b2) (C.dom a1) (prod (C.cod a1) (C.cod b2)) \<and>
                             (C (proj1 (C.cod a1) (C.cod b2)) (UP_map a1 b2) = a1 \<and>
                              C (proj2 (C.cod a1) (C.cod b2)) (UP_map a1 b2) = b2)"
    apply (rule_tac UP_existence)
      apply (simp_all add: arr_a1 arr_b2)
    unfolding a1_def b2_def
    apply (subst C.dom_comp)
    using arr_a1
    unfolding a1_def apply simp
    apply (subst C.dom_comp)
    using arr_b2
    unfolding b2_def apply simp
    by (simp add: proj_dom_eq)

  then have UP_in_hom : "C.in_hom (UP_map a1 b2) (C.dom a1) (prod (C.cod a1) (C.cod b2))"
    by simp

  show "C.arr (prod_functor (a, b))"
    unfolding prod_functor_def
    apply (simp add: arr_a arr_b)
    unfolding reverse_equality [OF a1_def]
    unfolding reverse_equality [OF b2_def]
    apply (rule_tac C.in_homE [OF UP_in_hom])
    by simp

  have dom_seq1 : "C.seq (C.dom a) (proj1 (C.dom a) (C.dom b))"
      apply (rule_tac C.seqI')
    using proj1_prop apply simp
    using C.in_homI [OF C.ideD(1) [OF C.ide_dom [OF arr_a]]]
    unfolding C.dom_dom [OF arr_a] by blast
  have dom_seq2 : "C.seq (C.dom b) (proj2 (C.dom a) (C.dom b))"
     apply (rule_tac C.seqI')
    using proj2_prop apply simp
    using C.in_homI [OF C.ideD(1) [OF C.ide_dom [OF arr_b]]]
    unfolding C.dom_dom [OF arr_b] by blast

  show "C.dom (prod_functor (a, b)) = prod_functor (C.dom a, C.dom b)"
    unfolding prod_functor_def
    apply (simp add: arr_a arr_b)
    unfolding reverse_equality [OF a1_def]
    unfolding reverse_equality [OF b2_def]
    apply (rule_tac UP_uniqueness)
       apply (simp add: dom_seq1)
      apply (simp add: dom_seq2)
    unfolding C.dom_comp [OF dom_seq1]
    unfolding C.dom_comp [OF dom_seq2]
     apply (simp add: proj_dom_eq)
    unfolding C.cod_comp [OF dom_seq1]
    unfolding C.cod_comp [OF dom_seq2]
    unfolding C.cod_dom [OF arr_a]
    unfolding C.cod_dom [OF arr_b]
    apply safe
  proof-
    have eq1: "C.dom (UP_map a1 b2) = C.dom (proj1 (C.dom a) (C.dom b))"
       apply (rule_tac C.in_homE [OF UP_in_hom])
       apply simp
       apply (subst a1_def)
       apply (subst C.dom_comp)
      using arr_a1 a1_def apply simp
      by simp

    have eq2: "C.dom (proj1 (C.dom a) (C.dom b)) = prod (C.dom a) (C.dom b)"
      apply (rule_tac C.in_homE [OF proj1_prop])
      by simp
    show dom_in_hom: "\<guillemotleft>C.dom (UP_map a1 b2) : C.dom (proj1 (C.dom a) (C.dom b)) \<rightarrow> prod (C.dom a) (C.dom b)\<guillemotright>"
      unfolding eq1
      unfolding eq2
      using C.ide_dom arr_a arr_b prod_obj by auto
    show "C (proj1 (C.dom a) (C.dom b)) (C.dom (UP_map a1 b2)) = C (C.dom a) (proj1 (C.dom a) (C.dom b))"
      apply (subst C.comp_ide_arr [OF C.ide_dom [OF arr_a] dom_seq1])
      apply (subst C.comp_arr_ide [OF C.ide_dom])
        apply (rule_tac C.in_homE [OF UP_in_hom])
        apply simp
       apply (rule_tac C.seqI')
      using dom_in_hom apply simp
      using proj1_prop apply simp
      by simp
    show "C (proj2 (C.dom a) (C.dom b)) (C.dom (UP_map a1 b2)) = C (C.dom b) (proj2 (C.dom a) (C.dom b))"
      apply (subst C.comp_ide_arr [OF C.ide_dom [OF arr_b] dom_seq2])
      apply (subst C.comp_arr_ide [OF C.ide_dom])
        apply (rule_tac C.in_homE [OF UP_in_hom])
        apply simp
       apply (rule_tac C.seqI')
      using dom_in_hom apply simp
      using proj2_prop apply simp
      by simp
  qed

  have proj1_prop2: "\<guillemotleft>proj1 (C.cod a) (C.cod b) : prod (C.cod a) (C.cod b) \<rightarrow> C.cod a\<guillemotright>"
    using proj1_in_hom [OF C.ide_cod [OF arr_a]
                           C.ide_cod [OF arr_b]].
  have proj2_prop2: "\<guillemotleft>proj2 (C.cod a) (C.cod b) : prod (C.cod a) (C.cod b) \<rightarrow> C.cod b\<guillemotright>"
    using proj2_in_hom [OF C.ide_cod [OF arr_a]
                           C.ide_cod [OF arr_b]].

  have proj_dom_eq2: "C.dom (proj1 (C.cod a) (C.cod b)) = C.dom (proj2 (C.cod a) (C.cod b))"
    apply (rule_tac C.in_homE [OF proj1_prop2])
    apply (rule_tac C.in_homE [OF proj2_prop2])
    by simp

  have cod_seq1: "C.seq (C.cod a) (proj1 (C.cod a) (C.cod b))"
    apply (rule_tac C.seqI')
    using proj1_prop2 apply simp
    apply (subst reverse_equality [OF C.ide_in_hom])
    using C.ide_cod [OF arr_a] by simp
  have cod_seq2 : "C.seq (C.cod b) (proj2 (C.cod a) (C.cod b))"
    apply (rule_tac C.seqI')
    using proj2_prop2 apply simp
    apply (subst reverse_equality [OF C.ide_in_hom])
    using C.ide_cod [OF arr_b] by simp

  show "C.cod (prod_functor (a, b)) = prod_functor (C.cod a, C.cod b)"
    unfolding prod_functor_def
    apply (simp add: arr_a arr_b)
    unfolding reverse_equality [OF a1_def]
    unfolding reverse_equality [OF b2_def]
    apply (rule_tac UP_uniqueness)
       apply (simp add: cod_seq1)
      apply (simp add: cod_seq2)
    unfolding C.dom_comp [OF cod_seq1]
    unfolding C.dom_comp [OF cod_seq2]
     apply (simp add: proj_dom_eq2)
    unfolding C.cod_comp [OF cod_seq1]
    unfolding C.cod_comp [OF cod_seq2]
    unfolding C.cod_cod [OF arr_a]
    unfolding C.cod_cod [OF arr_b]
    apply safe
  proof-
    have eq1: "C.cod (UP_map a1 b2) = prod (C.cod a) (C.cod b)"
       apply (rule_tac C.in_homE [OF UP_in_hom])
       apply simp
       apply (subst a1_def)
      apply (subst C.cod_comp)
       apply (rule_tac C.seqI')
      using proj1_prop apply simp
      using C.in_homI [OF arr_a] apply blast
      apply (subst b2_def)
      apply (subst C.cod_comp)
       apply (rule_tac C.seqI')
      using proj2_prop apply simp
      using C.in_homI [OF arr_b] apply blast
      by simp

    have eq2: "C.dom (proj1 (C.cod a) (C.cod b)) = prod (C.cod a) (C.cod b)"
      apply (rule_tac C.in_homE [OF proj1_prop2])
      by simp
    show cod_in_hom: "\<guillemotleft>C.cod (UP_map a1 b2) : C.dom (proj1 (C.cod a) (C.cod b)) \<rightarrow> prod (C.cod a) (C.cod b)\<guillemotright>"
      unfolding eq1
      unfolding eq2
      using C.ide_dom arr_a arr_b prod_obj by auto
    show "C (proj1 (C.cod a) (C.cod b)) (C.cod (UP_map a1 b2)) = C (C.cod a) (proj1 (C.cod a) (C.cod b))"
      apply (subst C.comp_ide_arr [OF C.ide_cod [OF arr_a] cod_seq1])
      apply (subst C.comp_arr_ide [OF C.ide_cod])
        apply (rule_tac C.in_homE [OF UP_in_hom])
        apply simp
       apply (rule_tac C.seqI')
      using cod_in_hom apply simp
      using proj1_prop2 apply simp
      by simp
    show "C (proj2 (C.cod a) (C.cod b)) (C.cod (UP_map a1 b2)) = C (C.cod b) (proj2 (C.cod a) (C.cod b))"
      apply (subst C.comp_ide_arr [OF C.ide_cod [OF arr_b] cod_seq2])
      apply (subst C.comp_arr_ide [OF C.ide_cod])
        apply (rule_tac C.in_homE [OF UP_in_hom])
        apply simp
       apply (rule_tac C.seqI')
      using cod_in_hom apply simp
      using proj2_prop2 apply simp
      by simp
  qed
next
  fix a b c d
  assume arr_comp1: "C.arr (fst (CxC.comp (a, b) (c, d)))"
  have "\<not> (C.arr c \<and> C.arr d \<and> C.arr a \<and> C.arr b \<and> C.cod c = C.dom a \<and> C.cod d = C.dom b) \<Longrightarrow> False"
  proof-
    assume "\<not> (C.arr c \<and> C.arr d \<and> C.arr a \<and> C.arr b \<and> C.cod c = C.dom a \<and> C.cod d = C.dom b)"
    then have null_eq: "fst (CxC.comp (a, b) (c, d)) = C.null"
      unfolding CxC.comp_def by auto
    show "False"
      using arr_comp1
      unfolding null_eq
      using C.not_arr_null
      by simp
  qed
  then have arr_abcd: "C.arr c \<and> C.arr d \<and> C.arr a \<and> C.arr b \<and> C.cod c = C.dom a \<and> C.cod d = C.dom b"
    by auto

  from arr_abcd have "C.arr a" by blast
  from arr_abcd have "C.arr b" by blast
  from arr_abcd have "C.arr c" by blast
  from arr_abcd have "C.arr d" by blast
  from arr_abcd have "C.cod c = C.dom a" by blast
  from arr_abcd have "C.cod d = C.dom b" by blast

  have proj1_in_hom_cd : "\<guillemotleft>proj1 (C.dom c) (C.dom d) : prod (C.dom c) (C.dom d) \<rightarrow> (C.dom c)\<guillemotright>"
    apply (rule_tac proj1_in_hom [OF C.ide_dom C.ide_dom])
    by (simp_all add: arr_abcd)

  have seq_ac : "C.seq a c"
    apply (rule_tac C.seqI)
    using arr_abcd by simp_all
  have ac_in_hom : "\<guillemotleft>C a c : C.dom c \<rightarrow> C.cod a\<guillemotright>"
    apply (rule_tac C.comp_in_homI)
    using C.in_homI arr_abcd apply blast
    using C.in_homI arr_abcd by blast

  have proj2_in_hom_cd : "\<guillemotleft>proj2 (C.dom c) (C.dom d) : prod (C.dom c) (C.dom d) \<rightarrow> (C.dom d)\<guillemotright>"
    apply (rule_tac proj2_in_hom [OF C.ide_dom C.ide_dom])
    by (simp_all add: arr_abcd)

  have bd_in_hom : "\<guillemotleft>C b d : C.dom d \<rightarrow> C.cod b\<guillemotright>"
    apply (rule_tac C.comp_in_homI)
    using C.in_homI arr_abcd apply blast
    using C.in_homI arr_abcd by blast
  have seq_bd : "C.seq b d"
    apply (rule_tac C.seqI)
    using arr_abcd by simp_all

  assume arr_comp2: "C.arr (snd (CxC.comp (a, b) (c, d)))"

  define a1 where "a1 = C a (proj1 (C.dom a) (C.dom b))"
  define b2 where "b2 = C b (proj2 (C.dom a) (C.dom b))"
  define c1 where "c1 = C c (proj1 (C.dom c) (C.dom d))"
  define d2 where "d2 = C d (proj2 (C.dom c) (C.dom d))"

  have a1_in_hom : "\<guillemotleft> a1 : C.dom (proj1 (C.dom a) (C.dom b)) \<rightarrow> C.cod a \<guillemotright>"
    unfolding a1_def
    apply (rule_tac C.comp_in_homI)
     apply (rule_tac C.in_homE [OF proj1_in_hom
                    [OF C.ide_dom [OF \<open>C.arr a\<close>]
                        C.ide_dom [OF \<open>C.arr b\<close>]]])
     apply blast
    using C.in_homI [OF \<open>C.arr a\<close>] by simp
  have b2_in_hom : "\<guillemotleft> b2 : C.dom (proj2 (C.dom a) (C.dom b)) \<rightarrow> C.cod b \<guillemotright>"
    unfolding b2_def
    apply (rule_tac C.comp_in_homI)
     apply (rule_tac C.in_homE [OF proj2_in_hom
                    [OF C.ide_dom [OF \<open>C.arr a\<close>]
                        C.ide_dom [OF \<open>C.arr b\<close>]]])
     apply blast
    using C.in_homI [OF \<open>C.arr b\<close>] by simp
    have c1_in_hom : "\<guillemotleft> c1 : C.dom (proj1 (C.dom c) (C.dom d)) \<rightarrow> C.cod c \<guillemotright>"
    unfolding c1_def
    apply (rule_tac C.comp_in_homI)
     apply (rule_tac C.in_homE [OF proj1_in_hom
                    [OF C.ide_dom [OF \<open>C.arr c\<close>]
                        C.ide_dom [OF \<open>C.arr d\<close>]]])
     apply blast
    using C.in_homI [OF \<open>C.arr c\<close>] by simp
  have d2_in_hom : "\<guillemotleft> d2 : C.dom (proj2 (C.dom c) (C.dom d)) \<rightarrow> C.cod d \<guillemotright>"
    unfolding d2_def
    apply (rule_tac C.comp_in_homI)
     apply (rule_tac C.in_homE [OF proj2_in_hom
                    [OF C.ide_dom [OF \<open>C.arr c\<close>]
                        C.ide_dom [OF \<open>C.arr d\<close>]]])
     apply blast
    using C.in_homI [OF \<open>C.arr d\<close>] by simp

  show "prod_functor (CxC.comp (a, b) (c, d)) = C (prod_functor (a, b)) (prod_functor (c, d))"
    unfolding prod_functor_def
    apply (simp add: arr_comp1 arr_comp2 arr_abcd)
    apply (rule_tac reverse_equality)
    apply (rule_tac UP_uniqueness)
       apply (rule_tac C.seqI' [OF proj1_in_hom_cd ac_in_hom])
      apply (rule_tac C.seqI' [OF proj2_in_hom_cd bd_in_hom])
    unfolding C.dom_comp [OF C.seqI' [OF proj1_in_hom_cd ac_in_hom]]
    unfolding C.dom_comp [OF C.seqI' [OF proj2_in_hom_cd bd_in_hom]]
    apply (rule_tac C.in_homE [OF proj1_in_hom_cd])
     apply (rule_tac C.in_homE [OF proj2_in_hom_cd])
     apply simp
    unfolding C.cod_comp [OF C.seqI' [OF proj1_in_hom_cd ac_in_hom]]
    unfolding C.cod_comp [OF C.seqI' [OF proj2_in_hom_cd bd_in_hom]]
    unfolding C.cod_comp [OF seq_ac]
    unfolding C.cod_comp [OF seq_bd]
    unfolding reverse_equality [OF a1_def]
    unfolding reverse_equality [OF b2_def]
    unfolding reverse_equality [OF c1_def]
    unfolding reverse_equality [OF d2_def]
    apply safe
      apply (rule_tac C.comp_in_homI)
  proof-
    have ab_dom_eq : "C.dom (proj1 (C.dom a) (C.dom b)) = C.dom (proj2 (C.dom a) (C.dom b))"
      apply (rule_tac C.in_homE [OF  proj1_in_hom
                    [OF C.ide_dom [OF \<open>C.arr a\<close>]
                        C.ide_dom [OF \<open>C.arr b\<close>]]])
      apply (rule_tac C.in_homE [OF  proj2_in_hom
                    [OF C.ide_dom [OF \<open>C.arr a\<close>]
                        C.ide_dom [OF \<open>C.arr b\<close>]]])
      by simp
    have ab_UP : "\<guillemotleft>UP_map a1 b2 : C.dom a1 \<rightarrow> prod (C.cod a1) (C.cod b2)\<guillemotright> \<and>
                   C (proj1 (C.cod a1) (C.cod b2)) (UP_map a1 b2) = a1 \<and>
                   C (proj2 (C.cod a1) (C.cod b2)) (UP_map a1 b2) = b2"
      apply (rule_tac UP_existence)
      using a1_in_hom apply blast
      using b2_in_hom apply blast
      apply (rule_tac C.in_homE [OF a1_in_hom])
      apply (rule_tac C.in_homE [OF b2_in_hom])
      by (simp add: ab_dom_eq)

    have cd_dom_eq : "C.dom (proj1 (C.dom c) (C.dom d)) = C.dom (proj2 (C.dom c) (C.dom d))"
      apply (rule_tac C.in_homE [OF  proj1_in_hom
                    [OF C.ide_dom [OF \<open>C.arr c\<close>]
                        C.ide_dom [OF \<open>C.arr d\<close>]]])
      apply (rule_tac C.in_homE [OF  proj2_in_hom
                    [OF C.ide_dom [OF \<open>C.arr c\<close>]
                        C.ide_dom [OF \<open>C.arr d\<close>]]])
      by simp
    have cd_UP : "\<guillemotleft>UP_map c1 d2 : C.dom c1 \<rightarrow> prod (C.cod c1) (C.cod d2)\<guillemotright> \<and>
                   C (proj1 (C.cod c1) (C.cod d2)) (UP_map c1 d2) = c1 \<and>
                   C (proj2 (C.cod c1) (C.cod d2)) (UP_map c1 d2) = d2"
      apply (rule_tac UP_existence)
      using c1_in_hom apply blast
      using d2_in_hom apply blast
      apply (rule_tac C.in_homE [OF c1_in_hom])
      apply (rule_tac C.in_homE [OF d2_in_hom])
      by (simp add: cd_dom_eq)
    show "\<guillemotleft>UP_map c1 d2 : C.dom (proj1 (C.dom c) (C.dom d)) \<rightarrow> prod (C.cod c) (C.cod d)\<guillemotright>"
      using conjunct1 [OF cd_UP]
      unfolding C.in_hom_dom [OF c1_in_hom]
                C.in_hom_cod [OF c1_in_hom]
                C.in_hom_cod [OF d2_in_hom].
    show "\<guillemotleft>UP_map a1 b2 : prod (C.cod c) (C.cod d) \<rightarrow> prod (C.cod a) (C.cod b)\<guillemotright>"
      using conjunct1 [OF ab_UP]
      unfolding C.in_hom_dom [OF a1_in_hom]
                C.in_hom_cod [OF a1_in_hom]
                C.in_hom_cod [OF b2_in_hom]
                C.in_hom_dom [OF proj1_in_hom
                    [OF C.ide_dom [OF \<open>C.arr a\<close>]
                        C.ide_dom [OF \<open>C.arr b\<close>]]]
      using arr_abcd by simp
    show "C (proj1 (C.cod a) (C.cod b)) (C (UP_map a1 b2) (UP_map c1 d2)) =
          C (C a c) (proj1 (C.dom c) (C.dom d))"
      apply (subst reverse_equality [OF C.comp_assoc])
      using conjunct2 [OF ab_UP]
      unfolding C.in_hom_cod [OF a1_in_hom]
                C.in_hom_cod [OF b2_in_hom]
      apply simp
      apply (subst a1_def)
      apply (subst C.comp_assoc)
      using conjunct2 [OF cd_UP]
      unfolding C.in_hom_cod [OF c1_in_hom]
                C.in_hom_cod [OF d2_in_hom]
      unfolding \<open>C.cod c = C.dom a\<close>
                \<open>C.cod d = C.dom b\<close>
      apply simp
      apply (subst c1_def)
      apply (subst C.comp_assoc)
      by simp
    show "C (proj2 (C.cod a) (C.cod b)) (C (UP_map a1 b2) (UP_map c1 d2)) =
          C (C b d) (proj2 (C.dom c) (C.dom d))"
      apply (subst reverse_equality [OF C.comp_assoc])
      using conjunct2 [OF ab_UP]
      unfolding C.in_hom_cod [OF a1_in_hom]
                C.in_hom_cod [OF b2_in_hom]
      apply simp
      apply (subst b2_def)
      apply (subst C.comp_assoc)
      using conjunct2 [OF cd_UP]
      unfolding C.in_hom_cod [OF c1_in_hom]
                C.in_hom_cod [OF d2_in_hom]
      unfolding \<open>C.cod c = C.dom a\<close>
                \<open>C.cod d = C.dom b\<close>
      apply simp
      apply (subst d2_def)
      apply (subst C.comp_assoc)
      by simp
  qed
qed

lemma prod_functor_obj : "\<And>a b. C.ide a \<Longrightarrow> C.ide b \<Longrightarrow> prod_functor (a, b) = prod a b"
  unfolding prod_functor_def
  apply simp
  apply (rule_tac reverse_equality [OF UP_uniqueness])
proof-
  fix a b
  show seq1: "C.ide a \<Longrightarrow> C.ide b \<Longrightarrow> C.seq a (proj1 a b)"
    apply (rule_tac C.seqI')
    using proj1_in_hom apply blast
    using C.ide_in_hom by simp
  show seq2: "C.ide a \<Longrightarrow> C.ide b \<Longrightarrow> C.seq b (proj2 a b)"
    apply (rule_tac C.seqI')
    using proj2_in_hom apply blast
    using C.ide_in_hom by simp
  show "C.ide a \<Longrightarrow> C.ide b \<Longrightarrow> C.dom (C a (proj1 a b)) = C.dom (C b (proj2 a b))"
    unfolding C.dom_comp [OF seq1]
    unfolding C.dom_comp [OF seq2]
    unfolding C.in_hom_dom [OF proj1_in_hom]
    unfolding C.in_hom_dom [OF proj2_in_hom]
    by simp
  show "C.ide a \<Longrightarrow>
           C.ide b \<Longrightarrow>
           \<guillemotleft>prod a b : C.dom (C a (proj1 a b)) \<rightarrow> prod (C.cod (C a (proj1 a b))) (C.cod (C b (proj2 a b)))\<guillemotright> \<and>
           C (proj1 (C.cod (C a (proj1 a b))) (C.cod (C b (proj2 a b)))) (prod a b) = C a (proj1 a b) \<and>
           C (proj2 (C.cod (C a (proj1 a b))) (C.cod (C b (proj2 a b)))) (prod a b) = C b (proj2 a b)"
    apply auto
    unfolding C.dom_comp [OF seq1]
    unfolding C.cod_comp [OF seq1]
    unfolding C.cod_comp [OF seq2]
    unfolding C.in_hom_dom [OF proj1_in_hom]
    unfolding C.ideD(3)
    using prod_obj
    using C.ide_in_hom
      apply simp
     apply (subst C.comp_arr_ide)
       apply (simp add: prod_obj)
      apply (rule_tac C.seqI')
    using prod_obj C.ide_in_hom apply blast
    using proj1_in_hom apply blast
     apply (subst C.comp_ide_arr)
    apply simp
      apply (rule_tac C.seqI')
    using proj1_in_hom apply blast
    using C.ide_in_hom apply blast
     apply simp
    apply (subst C.comp_arr_ide)
      apply (simp add: prod_obj)
     apply (rule_tac C.seqI')
    using prod_obj C.ide_in_hom apply blast
    using proj2_in_hom apply blast
    apply (subst C.comp_ide_arr)
      apply simp
     apply (rule_tac C.seqI')
    using proj2_in_hom apply blast
    using C.ide_in_hom apply blast
    by simp
qed

end

locale classical_functor =
  CC1 : classical_category Obj1 Arr1 Dom1 Cod1 Ide1 Comp1 +
  CC2 : classical_category Obj2 Arr2 Dom2 Cod2 Ide2 Comp2
  for Obj1 :: "'a \<Rightarrow> bool"
    and Arr1 :: "'b \<Rightarrow> bool"
    and Dom1 :: "'b \<Rightarrow> 'a"
    and Cod1 :: "'b \<Rightarrow> 'a"
    and Ide1 :: "'a \<Rightarrow> 'b"
    and Comp1 :: "'b \<Rightarrow> 'b \<Rightarrow> 'b"
    and Obj2 :: "'c \<Rightarrow> bool"
    and Arr2 :: "'d \<Rightarrow> bool"
    and Dom2 :: "'d \<Rightarrow> 'c"
    and Cod2 :: "'d \<Rightarrow> 'c"
    and Ide2 :: "'c \<Rightarrow> 'd"
    and Comp2 :: "'d \<Rightarrow> 'd \<Rightarrow> 'd"
  and FOb :: "'a \<Rightarrow> 'c"
  and FArr :: "'b \<Rightarrow> 'd" +
assumes F_preserves_Obj : "\<And>a. Obj1 a \<Longrightarrow> Obj2 (FOb a)"
  and   F_preserves_Arr : "\<And>b. Arr1 b \<Longrightarrow> Arr2 (FArr b)"
  and   F_preserves_Dom : "\<And>b. Arr1 b \<Longrightarrow> Dom2 (FArr b) = FOb (Dom1 b)"
  and   F_preserves_Cod : "\<And>b. Arr1 b \<Longrightarrow> Cod2 (FArr b) = FOb (Cod1 b)"
  and   F_preserves_Id  : "\<And>a. Obj1 a \<Longrightarrow> FArr (Ide1 a) = Ide2 (FOb a)"
  and   F_preserves_Comp: "\<And>g f. Arr1 g \<Longrightarrow> Arr1 f \<Longrightarrow> Dom1 g = Cod1 f \<Longrightarrow>
                           FArr (Comp1 g f) = Comp2 (FArr g) (FArr f)"
begin

definition map :: "'b option \<Rightarrow> 'd option" where
  "map b = (if CC1.arr b then Some (FArr (the b)) else CC2.null)"

lemma is_functor : "functor CC1.comp CC2.comp map"
  unfolding functor_def
  apply (simp add: CC1.induces_category CC2.induces_category)
  unfolding functor_axioms_def
  apply safe
proof-
  show "\<And>f. \<not> CC1.arr f \<Longrightarrow> local.map f = CC2.null"
    unfolding map_def by simp
  show map_arr: "\<And>f. CC1.arr f \<Longrightarrow> CC2.arr (local.map f)"
    unfolding map_def apply simp
    unfolding CC1.arr_char CC2.arr_char
    using F_preserves_Arr by simp
  show map_dom: "\<And>f. CC1.arr f \<Longrightarrow> CC2.dom (local.map f) = local.map (CC1.dom f)"
    unfolding map_def apply simp
    unfolding CC1.dom_char CC2.dom_char apply auto
    using map_arr unfolding map_def apply auto
    unfolding CC1.arr_char
    apply (subst F_preserves_Dom)
     apply simp
    apply (subst F_preserves_Id)
    using CC1.Obj_Dom by simp_all
  show map_cod: "\<And>f. CC1.arr f \<Longrightarrow> CC2.cod (local.map f) = local.map (CC1.cod f)"
    unfolding map_def apply simp
    unfolding CC1.cod_char CC2.cod_char apply auto
    using map_arr unfolding map_def apply auto
    unfolding CC1.arr_char
    apply (subst F_preserves_Cod)
     apply simp
    apply (subst F_preserves_Id)
    using CC1.Obj_Cod by simp_all
  fix g f
  assume "CC1.seq g f"
  have H: "Ide1 (Dom1 (the g)) = Ide1 (Cod1 (the f)) \<Longrightarrow>
        Cod1 (the f) = Dom1 (the g)"
    using CC1.arr_char CC1.comp_def \<open>CC1.seq g f\<close> by fastforce

  show "local.map (CC1.comp g f) = CC2.comp (local.map g) (local.map f)"
    apply (rule_tac CC1.seqE [OF \<open>CC1.seq g f\<close>])
    unfolding map_def apply simp
    unfolding CC1.dom_char CC1.cod_char apply simp
    unfolding CC1.arr_char CC2.arr_char
    using H
    unfolding CC1.comp_char apply simp
    apply (subst F_preserves_Comp)
       apply simp_all
    unfolding CC2.comp_char apply simp
    using F_preserves_Arr F_preserves_Dom F_preserves_Cod
    by simp
qed
end

locale classical_full_subcategory =
  CC : classical_category Obj Arr Dom Cod Ide Comp
    for Obj :: "'a \<Rightarrow> bool"
    and Arr :: "'b \<Rightarrow> bool"
    and Dom :: "'b \<Rightarrow> 'a"
    and Cod :: "'b \<Rightarrow> 'a"
    and Ide :: "'a \<Rightarrow> 'b"
    and Comp :: "'b \<Rightarrow> 'b \<Rightarrow> 'b"
    and SObj :: "'a \<Rightarrow> bool" +
  assumes SObj_Obj : "\<And>x. SObj x \<Longrightarrow> Obj x"
begin

definition SArr where
  "SArr x = (Arr x \<and> SObj (Dom x) \<and> SObj (Cod x))"

interpretation SCC : classical_category SObj SArr Dom Cod Ide Comp
  unfolding classical_category_def
  unfolding SArr_def
  using SObj_Obj by simp

lemma is_classical_category : "classical_category SObj SArr Dom Cod Ide Comp"
  using SCC.classical_category_axioms.

interpretation Inclusion: classical_functor
       SObj SArr Dom Cod Ide Comp
       Obj Arr Dom Cod Ide Comp
       "(\<lambda>x. x)"
       "(\<lambda>x. x)"
  unfolding classical_functor_def
  apply (simp add: CC.classical_category_axioms SCC.classical_category_axioms)
  unfolding classical_functor_axioms_def
  using SObj_Obj apply simp
  unfolding SArr_def by simp

definition inclusion_functor where
  "inclusion_functor = Inclusion.map"

lemma inclusion_functor: "functor SCC.comp CC.comp inclusion_functor"
  unfolding inclusion_functor_def
  using Inclusion.is_functor.

lemma inclusion_functor_simp :
  "inclusion_functor x = (if SCC.arr x then x else None)"
  unfolding inclusion_functor_def
  unfolding Inclusion.map_def
  unfolding CC.null_char SCC.arr_char
  by simp

end

sublocale classical_full_subcategory \<subseteq> classical_category SObj SArr Dom Cod Ide Comp
  using is_classical_category.

context classical_category
begin

definition In_Hom where
  "In_Hom f A B = (Arr f \<and> Dom f = A \<and> Cod f = B)"

lemma in_hom_char: "in_hom f a b = (ide a \<and> ide b \<and> f \<noteq> None \<and> In_Hom (the f) (Dom (the a)) (Dom (the b)))"
  apply auto
proof-
  assume f_hom: "in_hom f a b"
  then have arr_f : "arr f"
    by blast
  then show "\<exists>y. f = Some y"
    unfolding arr_char by simp
  show "In_Hom (the f) (Dom (the a)) (Dom (the b))"
    apply (rule_tac in_homE [OF f_hom])
    unfolding In_Hom_def
    unfolding dom_char cod_char
    apply simp
    unfolding arr_char
    apply simp
  proof-
    assume eq_a: "Some (Id (Dom (the f))) = a"
    assume eq_b: "Some (Id (Cod (the f))) = b"
    show "Dom (the f) = Dom (the a) \<and> Cod (the f) = Dom (the b)"
      unfolding reverse_equality [OF eq_a]
      unfolding reverse_equality [OF eq_b]
      apply simp
      apply (subst Dom_Id)
       apply (rule_tac Obj_Dom)
      using arr_f arr_char apply simp
      apply (subst Dom_Id)
       apply (rule_tac Obj_Cod)
      using arr_f arr_char apply simp
      by simp
  qed
next
  fix y
  assume "ide a" "ide b"
  assume f_Hom: "In_Hom y (Dom (the a)) (Dom (the b))"
  assume "f = Some y"
  show "in_hom (Some y) a b"
    apply (rule_tac in_homI)
  proof-
    show arr_y: "arr (Some y)"
      unfolding arr_char apply simp
      using f_Hom
      unfolding In_Hom_def by simp
    show "dom (Some y) = a"
      unfolding dom_char
      using arr_y apply simp
      using f_Hom
      unfolding In_Hom_def apply simp
      using \<open>ide a\<close>
      unfolding ide_char by simp
    show "cod (Some y) = b"
      unfolding cod_char
      using arr_y apply simp
      using f_Hom
      unfolding In_Hom_def apply simp
      using \<open>ide b\<close>
      unfolding ide_char by simp
  qed
qed

end

locale classical_category_with_products =
  CC: classical_category Obj Arr Dom Cod Ide Comp
  for Obj :: "'a \<Rightarrow> bool"
  and Arr :: "'b \<Rightarrow> bool"
  and Dom :: "'b \<Rightarrow> 'a"
  and Cod :: "'b \<Rightarrow> 'a"
  and Ide :: "'a \<Rightarrow> 'b"
  and Comp :: "'b \<Rightarrow> 'b \<Rightarrow> 'b"
  and Prod :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"
  and Proj1 :: "'a \<Rightarrow> 'a \<Rightarrow> 'b"
  and Proj2 :: "'a \<Rightarrow> 'a \<Rightarrow> 'b" +
assumes Prod_Obj : "\<And> a b . Obj a \<Longrightarrow> Obj b \<Longrightarrow> Obj (Prod a b)"
  and Proj1_In_Hom : "\<And> a b . Obj a \<Longrightarrow> Obj b \<Longrightarrow> CC.In_Hom (Proj1 a b) (Prod a b) a"
  and Proj2_In_Hom : "\<And> a b . Obj a \<Longrightarrow> Obj b \<Longrightarrow> CC.In_Hom (Proj2 a b) (Prod a b) b"
  and UP : "\<And>a b c f g. CC.In_Hom f c a \<Longrightarrow> CC.In_Hom g c b \<Longrightarrow>
            \<exists>! h. CC.In_Hom h c (Prod a b) \<and> Comp (Proj1 a b) h = f \<and> Comp (Proj2 a b) h = g"
begin

definition UP_map where
  "UP_map a b c f g = (SOME h. CC.In_Hom h c (Prod a b) \<and> Comp (Proj1 a b) h = f \<and> Comp (Proj2 a b) h = g)"

lemma UP_existence : "\<And>a b c f g. CC.In_Hom f c a \<Longrightarrow> CC.In_Hom g c b \<Longrightarrow>
            CC.In_Hom (UP_map a b c f g) c (Prod a b) \<and>
            Comp (Proj1 a b) (UP_map a b c f g) = f \<and>
            Comp (Proj2 a b) (UP_map a b c f g) = g"
  unfolding UP_map_def
  apply (rule_tac someI_ex)
  using UP by blast

lemma UP_uniqueness: "\<And>a b c f g h. CC.In_Hom f c a \<Longrightarrow> CC.In_Hom g c b \<Longrightarrow>
            CC.In_Hom h c (Prod a b) \<and>
            Comp (Proj1 a b) h = f \<and>
            Comp (Proj2 a b) h = g
            \<Longrightarrow> h = (UP_map a b c f g)"
proof-
  fix a b c f g h
  assume f_hom : "CC.In_Hom f c a"
  assume g_hom : "CC.In_Hom g c b"
  assume h_prop: "CC.In_Hom h c (Prod a b) \<and> Comp (Proj1 a b) h = f \<and> Comp (Proj2 a b) h = g"
  have UP_map_prop: "CC.In_Hom (UP_map a b c f g) c (Prod a b) \<and>
        Comp (Proj1 a b) (UP_map a b c f g) = f \<and>
        Comp (Proj2 a b) (UP_map a b c f g) = g"
    using UP_existence [OF f_hom g_hom].
  have "\<exists>! h. CC.In_Hom h c (Prod a b) \<and> Comp (Proj1 a b) h = f \<and> Comp (Proj2 a b) h = g"
    using UP [OF f_hom g_hom].
  then show "h = UP_map a b c f g"
    using h_prop UP_map_prop by auto
qed

lemma "category_with_products CC.comp
       (\<lambda>a b . Some (Ide (Prod (Dom (the a)) (Dom (the b)))))
       (\<lambda>a b . Some (Proj1 (Dom (the a)) (Dom (the b))))
       (\<lambda>a b . Some (Proj2 (Dom (the a)) (Dom (the b))))
       (\<lambda>f g . Some (UP_map (Cod (the f)) (Cod (the g)) (Dom (the f)) (the f) (the g)))"
  unfolding category_with_products_def
  unfolding category_with_products_axioms_def
  unfolding binary_product_def
  apply (simp add: CC.induces_category)
  unfolding binary_product_axioms_def
  apply auto
proof-
  have prod_obj: "\<And>a b. CC.ide a \<Longrightarrow> CC.ide b \<Longrightarrow> Obj (Prod (Dom (the a)) (Dom (the b)))"
    apply (rule_tac Prod_Obj)
    unfolding CC.ide_char
    using CC.Obj_Dom by auto
  show prod_ide: "\<And>a b. CC.ide a \<Longrightarrow> CC.ide b \<Longrightarrow> CC.ide (Some (Ide (Prod (Dom (the a)) (Dom (the b)))))"
    apply (subst CC.ide_char)
    using CC.Dom_Id [OF prod_obj] CC.Arr_Id [OF prod_obj] by simp
  show "\<And>a b. CC.ide a \<Longrightarrow>
           CC.ide b \<Longrightarrow>
           CC.in_hom (Some (Proj1 (Dom (the a)) (Dom (the b))))
           (Some (Ide (Prod (Dom (the a)) (Dom (the b))))) a"
    unfolding CC.in_hom_char
    apply (simp add: prod_ide)
    apply (subst CC.Dom_Id)
    using prod_obj apply simp
    apply (rule_tac Proj1_In_Hom)
     apply (rule_tac CC.Obj_Dom)
    apply (simp add: CC.ide_char)
     apply (rule_tac CC.Obj_Dom)
    by (simp add: CC.ide_char)
  show "\<And>a b. CC.ide a \<Longrightarrow>
           CC.ide b \<Longrightarrow>
           CC.in_hom (Some (Proj2 (Dom (the a)) (Dom (the b))))
           (Some (Ide (Prod (Dom (the a)) (Dom (the b))))) b"
    unfolding CC.in_hom_char
    apply (simp add: prod_ide)
    apply (subst CC.Dom_Id)
    using prod_obj apply simp
    apply (rule_tac Proj2_In_Hom)
     apply (rule_tac CC.Obj_Dom)
    apply (simp add: CC.ide_char)
     apply (rule_tac CC.Obj_Dom)
    by (simp add: CC.ide_char)
  show "\<And>f g. CC.arr f \<Longrightarrow>
           CC.arr g \<Longrightarrow>
           CC.dom f = CC.dom g \<Longrightarrow>
           CC.in_hom (Some (UP_map (Cod (the f)) (Cod (the g)) (Dom (the f)) (the f) (the g))) (CC.dom g)
            (Some (Ide (Prod (Dom (the (CC.cod f))) (Dom (the (CC.cod g))))))"
    unfolding CC.in_hom_char
    apply auto
    using prod_ide apply simp
    apply (subst CC.Dom_Id)
    using prod_obj apply simp
  proof-
    fix f g
    assume "CC.arr f"
    then have "Arr (the f)"
      unfolding CC.arr_char by simp
    assume "CC.arr g"
    then have "Arr (the g)"
      unfolding CC.arr_char by simp
    assume "CC.dom f = CC.dom g"
    then have "Dom (the f) = Dom (the g)"
      unfolding CC.dom_char CC.cod_char
      apply (simp add: \<open>CC.arr f\<close> \<open>CC.arr g\<close>)
      using CC.Dom_Id CC.Obj_Dom \<open>Arr (the f)\<close> \<open>Arr (the g)\<close> by fastforce
    show "CC.In_Hom (UP_map (Cod (the f)) (Cod (the g)) (Dom (the f)) (the f) (the g)) (Dom (the (CC.dom g)))
            (Prod (Dom (the (CC.cod f))) (Dom (the (CC.cod g))))"
      unfolding CC.dom_char CC.cod_char
      apply (simp add: \<open>CC.arr f\<close> \<open>CC.arr g\<close>)
      unfolding CC.Dom_Id [OF CC.Obj_Cod [OF \<open>Arr (the f)\<close>]]
      unfolding CC.Dom_Id [OF CC.Obj_Dom [OF \<open>Arr (the g)\<close>]]
      unfolding CC.Dom_Id [OF CC.Obj_Cod [OF \<open>Arr (the g)\<close>]]
      unfolding \<open>Dom (the f) = Dom (the g)\<close>
      apply (rule_tac conjunct1 [OF UP_existence])
      unfolding CC.In_Hom_def
      unfolding \<open>Dom (the f) = Dom (the g)\<close>
      by (simp_all add: \<open>Arr (the f)\<close> \<open>Arr (the g)\<close>)
  qed
(*TODO: Complete proof *)
  oops

end

context abstracted_category
begin

definition A_functor where
  "A_functor f = (if C.arr f then A f else null)"

lemma A_functor: "functor C comp A_functor"
  unfolding functor_def
  apply (simp add: C.category_axioms is_category)
  unfolding functor_axioms_def
  apply auto
      apply (simp add: A_functor_def)
proof-
  show arr: "\<And>f. C.arr f \<Longrightarrow> arr (A_functor f)"
    unfolding A_functor_def apply simp
    using domain_closed arr_char rep_abs by force
  show dom: "\<And>f. C.arr f \<Longrightarrow> local.dom (A_functor f) = A_functor (C.dom f)"
    unfolding A_functor_def apply simp
    by (simp add: arr_char dom_char domain_closed rep_abs)
  show "\<And>f. C.arr f \<Longrightarrow> cod (A_functor f) = A_functor (C.cod f)"
    unfolding A_functor_def apply simp
    by (simp add: arr_char cod_char domain_closed rep_abs)
  fix g f
  assume arr_gf : "C.seq g f"
  show "A_functor (g \<cdot>\<^sub>C f) = A_functor g \<cdot> A_functor f"
    apply (rule_tac C.seqE [OF arr_gf])
    unfolding A_functor_def apply simp
    by (simp add: domain_closed local.comp_def rep_abs)
qed

end

end


subsection\<open>Type preservation\<close>

theory TypePreservation
imports
    ContextFacts
begin

text\<open>Shifting lambda variables preserves well-typedness.\<close>

lemma liftL_type:
  "\<Gamma>, \<Delta> \<turnstile>\<^sub>T t : T \<Longrightarrow> \<forall>k. \<Gamma>\<langle>k:U\<rangle>, \<Delta> \<turnstile>\<^sub>T (liftL_trm t k) : T"
  "\<Gamma>, \<Delta> \<turnstile>\<^sub>C c \<Longrightarrow> \<forall>k. \<Gamma>\<langle>k:U\<rangle>, \<Delta> \<turnstile>\<^sub>C (liftL_cmd c k)"
  by (induct rule: typing_trm_typing_cmd.inducts) auto

text\<open>Shifting mu variables preserves well-typedness.\<close>

lemma liftM_type:
  "\<Gamma>, \<Delta> \<turnstile>\<^sub>T t : T \<Longrightarrow> \<forall>k. \<Gamma>, \<Delta>\<langle>k:U\<rangle> \<turnstile>\<^sub>T (liftM_trm t k) : T"
  "\<Gamma>, \<Delta> \<turnstile>\<^sub>C c \<Longrightarrow> \<forall>k. \<Gamma>, \<Delta>\<langle>k:U\<rangle> \<turnstile>\<^sub>C (liftM_cmd c k)"
  by(induct rule: typing_trm_typing_cmd.inducts) auto

lemma dropM_type:
  "\<Gamma> , \<Delta>1 \<turnstile>\<^sub>T t : T \<Longrightarrow> k \<notin> fmv_trm t 0 \<Longrightarrow> (\<forall>x. x<k \<longrightarrow> \<Delta>1 x = \<Delta> x)
    \<Longrightarrow> (\<forall>x. x>k \<longrightarrow> \<Delta>1 x = \<Delta> (x-1)) \<Longrightarrow> \<Gamma> , \<Delta> \<turnstile>\<^sub>T dropM_trm t k : T"
  "\<Gamma> , \<Delta>1 \<turnstile>\<^sub>C c \<Longrightarrow> k \<notin> fmv_cmd c 0 \<Longrightarrow> (\<forall>x. x<k \<longrightarrow> \<Delta>1 x = \<Delta> x)
    \<Longrightarrow> (\<forall>x. x>k \<longrightarrow> \<Delta>1 x = \<Delta> (x-1)) \<Longrightarrow> \<Gamma> , \<Delta> \<turnstile>\<^sub>C dropM_cmd c k"
proof (induct arbitrary: k \<Delta> and k \<Delta> rule: typing_trm_typing_cmd.inducts)
  case (activate \<Gamma> \<Delta> T c)
  then show ?case
    apply(erule_tac x = "Suc k" in meta_allE)
    apply(insert fmv_suc(1))
    apply(clarsimp simp add: shift_def)
    done
qed fastforce+

text\<open>Lifting $\lambda$ and $\mu$-variables in contexts preserves contextual typing judgements.\<close>

lemma liftL_ctxt_type:
  assumes "\<Gamma>, \<Delta> \<turnstile>\<^sub>c\<^sub>t\<^sub>x\<^sub>t E : T \<Leftarrow> U"
  shows   "\<forall>k. \<Gamma>\<langle>k:T1\<rangle>, \<Delta> \<turnstile>\<^sub>c\<^sub>t\<^sub>x\<^sub>t (liftL_ctxt E k) : T \<Leftarrow> U"
using assms by (induct rule: typing_ctxt.induct) (auto simp add: liftL_type)

lemma liftM_ctxt_type:
  assumes "\<Gamma>, \<Delta> \<turnstile>\<^sub>c\<^sub>t\<^sub>x\<^sub>t E : T \<Leftarrow> U"
  shows   "\<Gamma>, \<Delta>\<langle>k:T1\<rangle> \<turnstile>\<^sub>c\<^sub>t\<^sub>x\<^sub>t (liftM_ctxt E k) : T \<Leftarrow> U"
using assms by(induct rule: typing_ctxt.induct) (auto simp add: liftM_type)

text\<open>Substitution lemma for logical substitution.\<close>

theorem subst_type:
  "\<Gamma>1, \<Delta> \<turnstile>\<^sub>T t : T \<Longrightarrow> \<Gamma>, \<Delta> \<turnstile>\<^sub>T r : T1 \<Longrightarrow> \<Gamma>1 = \<Gamma>\<langle>k:T1\<rangle> \<Longrightarrow> \<Gamma>, \<Delta> \<turnstile>\<^sub>T t[r/k]\<^sup>T : T"
  "\<Gamma>1, \<Delta> \<turnstile>\<^sub>C c \<Longrightarrow> \<Gamma>, \<Delta> \<turnstile>\<^sub>T r : T1 \<Longrightarrow> \<Gamma>1 = \<Gamma>\<langle>k:T1\<rangle> \<Longrightarrow> \<Gamma>, \<Delta> \<turnstile>\<^sub>C c[r/k]\<^sup>C "
proof(induct arbitrary: \<Gamma> k T1 r and \<Gamma> k r T1 rule: typing_trm_typing_cmd.inducts)
  case (lambda \<Gamma> T1 \<Delta> t T2)
  then show ?case
    by -(rotate_tac 2, drule liftL_type(1), fastforce)
next
  case (activate \<Gamma> \<Delta> T c)
  then show ?case
    by -(rotate_tac 2, drule liftM_type(1), fastforce)
qed force+

text\<open>Substitution lemma for structural substitution. The proof is by induction on the first typing judgement.\<close>

lemma struct_subst_command:
  assumes "\<Gamma>, \<Delta> \<turnstile>\<^sub>T t : T" "\<Delta> x = T" "\<Gamma> , \<Delta>' \<turnstile>\<^sub>c\<^sub>t\<^sub>x\<^sub>t E : U \<Leftarrow> T1" "\<Delta> = \<Delta>'\<langle>\<alpha>:T1\<rangle>"
          "(\<Gamma> , \<Delta>' \<turnstile>\<^sub>c\<^sub>t\<^sub>x\<^sub>t E : U \<Leftarrow> T1 \<Longrightarrow> \<Delta> = \<Delta>'\<langle>\<alpha>:T1\<rangle> \<Longrightarrow> \<Gamma> , \<Delta>'\<langle>\<beta>:U\<rangle> \<turnstile>\<^sub>T t[\<alpha>=\<beta> (liftM_ctxt E \<beta>)]\<^sup>T : T)"
  shows   "\<Gamma>,( \<Delta>'\<langle>\<beta>:U\<rangle>) \<turnstile>\<^sub>C (<x> t)[\<alpha>=\<beta> (liftM_ctxt E \<beta>)]\<^sup>C"
  using assms apply clarsimp
  apply (rule conjI, force, clarsimp)+
  apply (rule conjI)
   apply (metis liftM_ctxt_type passivate shift_eq typing_ctxt_correct2)
  apply force
  done

theorem struct_subst_type:
  "\<Gamma>, \<Delta>1 \<turnstile>\<^sub>T t : T \<Longrightarrow> \<Gamma>, \<Delta> \<turnstile>\<^sub>c\<^sub>t\<^sub>x\<^sub>t E : U \<Leftarrow> T1 \<Longrightarrow> \<Delta>1 = \<Delta>\<langle>\<alpha>:T1\<rangle> \<Longrightarrow> \<Gamma>, \<Delta>\<langle>\<beta>:U\<rangle> \<turnstile>\<^sub>T t[\<alpha>=\<beta> (liftM_ctxt E \<beta>)]\<^sup>T : T"
  "\<Gamma>, \<Delta>1 \<turnstile>\<^sub>C c \<Longrightarrow> \<Gamma>, \<Delta> \<turnstile>\<^sub>c\<^sub>t\<^sub>x\<^sub>t E : U \<Leftarrow> T1  \<Longrightarrow> \<Delta>1 = \<Delta>\<langle>\<alpha>:T1\<rangle> \<Longrightarrow> \<Gamma>, \<Delta>\<langle>\<beta>:U\<rangle> \<turnstile>\<^sub>C c[\<alpha>=\<beta> (liftM_ctxt E \<beta>)]\<^sup>C"
proof (induct arbitrary: \<Delta> T1 E U \<beta> \<alpha> and \<Delta> T1 E U \<beta> \<alpha> rule: typing_trm_typing_cmd.inducts)
  case (lambda \<Gamma> T1 \<Delta> t T2)
  then show ?case
    by -(drule liftL_ctxt_type, fastforce simp: liftLM_comm_ctxt)
next
  case (activate \<Gamma> \<Delta> T c)
  then show ?case
    by -(drule liftM_ctxt_type, fastforce simp: liftMM_comm_ctxt)
next
  case (passivate \<Gamma> \<Delta> t T x)
  then show ?case
    using struct_subst_command by force
qed fastforce+

lemma struct_subst_type_command:  "\<Gamma>, \<Delta>1 \<turnstile>\<^sub>C c \<Longrightarrow> \<Gamma>, \<Delta> \<turnstile>\<^sub>c\<^sub>t\<^sub>x\<^sub>t E : U \<Leftarrow> T1
    \<Longrightarrow> \<Delta>1 = \<Delta>\<langle>\<alpha>:T1\<rangle>
    \<Longrightarrow> \<Gamma>, \<Delta>\<langle>\<beta>:U\<rangle> \<turnstile>\<^sub>C c[\<alpha>=\<beta> (liftM_ctxt E \<beta>)]\<^sup>C"
using struct_subst_type by force

lemma dropM_env:
  "\<Gamma>, \<Delta>1 \<turnstile>\<^sub>T t[k=x \<diamond>]\<^sup>T : T \<Longrightarrow> \<Delta>1 = \<Delta>\<langle>x:(\<Delta> x)\<rangle> \<Longrightarrow> \<Gamma> , \<Delta> \<turnstile>\<^sub>T dropM_trm (t[k=x \<diamond>]\<^sup>T) x : T"
  "\<Gamma>, \<Delta>1 \<turnstile>\<^sub>C c[k=x \<diamond>]\<^sup>C \<Longrightarrow> \<Delta>1 = \<Delta>\<langle>x:(\<Delta> x)\<rangle> \<Longrightarrow> \<Gamma> , \<Delta> \<turnstile>\<^sub>C dropM_cmd (c[k=x \<diamond>]\<^sup>C) x"
  by (induct t and c arbitrary: \<Gamma> T \<Delta>1 x k \<Delta> and \<Gamma> T \<Delta>1 x k \<Delta>) fastforce+

theorem type_preservation:
  "\<Gamma>, \<Delta> \<turnstile>\<^sub>T t : T \<Longrightarrow> t \<longlonglongrightarrow> s \<Longrightarrow> \<Gamma>, \<Delta> \<turnstile>\<^sub>T s : T"
  "\<Gamma>, \<Delta> \<turnstile>\<^sub>C c \<Longrightarrow> c \<^sub>C\<longlonglongrightarrow> d \<Longrightarrow> \<Gamma>, \<Delta> \<turnstile>\<^sub>C d"
proof(induct arbitrary: s and d rule: typing_trm_typing_cmd.inducts)
  case (app \<Gamma> \<Delta> t T1 T2 s s')
  then show ?case
    apply -
    apply (erule redE; clarsimp simp: subst_type(1))
      apply (subgoal_tac "\<Gamma> , \<Delta> \<turnstile>\<^sub>T ctxt_subst (\<diamond> \<^sup>\<bullet> s) (\<mu>(T1\<rightarrow>T2) : c) : T2")
       apply (drule typing_ctxt_correct1, clarsimp)
       apply (subgoal_tac "\<Gamma> , \<Delta>\<langle>0:T2\<rangle> \<turnstile>\<^sub>C c[0=0 (liftM_ctxt (\<diamond> \<^sup>\<bullet> s) 0)]\<^sup>C")
        apply (clarsimp, rule struct_subst_type_command)
         apply force+
    done
next
  case (passivate \<Gamma> \<Delta> t T x)
  then show ?case
    apply clarsimp
    apply (erule redE, clarsimp)
     apply (drule struct_subst_type_command [where \<beta> = x])
       apply (fastforce simp: dropM_env(2))+
    done
qed (force simp: dropM_type)+

end


(*
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

section "Lemmas for Word Length 32"

theory Word_Lemmas_32
imports
  Word_Lemmas
  Word_Setup_32
begin

lemma ucast_8_32_inj:
  "inj (ucast ::  8 word \<Rightarrow> 32 word)"
  by (rule down_ucast_inj) (clarsimp simp: is_down_def target_size source_size)

lemma upto_2_helper:
  "{0..<2 :: 32 word} = {0, 1}"
  by (safe; simp) unat_arith

lemmas upper_bits_unset_is_l2p_32 = upper_bits_unset_is_l2p [where 'a=32, folded word_bits_def]
lemmas le_2p_upper_bits_32 = le_2p_upper_bits [where 'a=32, folded word_bits_def]
lemmas le2p_bits_unset_32 = le2p_bits_unset[where 'a=32, folded word_bits_def]

lemma word_bits_len_of:
  "len_of TYPE (32) = word_bits"
  by (simp add: word_bits_conv)

lemmas unat_power_lower32' = unat_power_lower[where 'a=32]
lemmas unat_power_lower32 [simp] = unat_power_lower32'[unfolded word_bits_len_of]

lemmas word32_less_sub_le' = word_less_sub_le[where 'a = 32]
lemmas word32_less_sub_le[simp] = word32_less_sub_le' [folded word_bits_def]

lemma word_bits_size:
  "size (w::word32) = word_bits"
  by (simp add: word_bits_def word_size)

lemmas word32_power_less_1' = word_power_less_1[where 'a = 32]
lemmas word32_power_less_1[simp] = word32_power_less_1'[folded word_bits_def]

lemma of_nat32_0:
  "\<lbrakk>of_nat n = (0::word32); n < 2 ^ word_bits\<rbrakk> \<Longrightarrow> n = 0"
  by (erule of_nat_0, simp add: word_bits_def)

lemma unat_mask_2_less_4:
  "unat (p && mask 2 :: word32) < 4"
  apply (rule unat_less_helper)
  apply (rule order_le_less_trans, rule word_and_le1)
  apply (simp add: mask_def)
  done

lemmas unat_of_nat32' = unat_of_nat_eq[where 'a=32]
lemmas unat_of_nat32 = unat_of_nat32'[unfolded word_bits_len_of]

lemmas word_power_nonzero_32 = word_power_nonzero [where 'a=32, folded word_bits_def]

lemmas unat_mult_simple = iffD1 [OF unat_mult_lem [where 'a = 32, unfolded word_bits_len_of]]

lemmas div_power_helper_32 = div_power_helper [where 'a=32, folded word_bits_def]

lemma n_less_word_bits:
  "(n < word_bits) = (n < 32)"
  by (simp add: word_bits_def)

lemmas of_nat_less_pow_32 = of_nat_power [where 'a=32, folded word_bits_def]

lemma lt_word_bits_lt_pow:
  "sz < word_bits \<Longrightarrow> sz < 2 ^ word_bits"
  by (simp add: word_bits_conv)

lemma unat_less_word_bits:
  fixes y :: word32
  shows "x < unat y \<Longrightarrow> x < 2 ^ word_bits"
  unfolding word_bits_def
  by (rule order_less_trans [OF _ unat_lt2p])

lemmas unat_mask_word32' = unat_mask[where 'a=32]
lemmas unat_mask_word32 = unat_mask_word32'[folded word_bits_def]

lemma unat_less_2p_word_bits:
  "unat (x :: 32 word) < 2 ^ word_bits"
  apply (simp only: word_bits_def)
  apply (rule unat_lt2p)
  done

lemma Suc_unat_mask_div:
  "Suc (unat (mask sz div word_size::word32)) = 2 ^ (min sz word_bits - 2)"
  apply (case_tac "sz < word_bits")
   apply (case_tac "2\<le>sz")
    apply (clarsimp simp: word_size_def word_bits_def min_def mask_def)
    apply (drule (2) Suc_div_unat_helper
           [where 'a=32 and sz=sz and us=2, simplified, symmetric])
   apply (simp add: not_le word_size_def word_bits_def)
   apply (case_tac sz, simp add: unat_word_ariths)
   apply (case_tac nat, simp add: unat_word_ariths
                                  unat_mask_word32 min_def word_bits_def)
   apply simp
  apply (simp add: unat_word_ariths
                   unat_mask_word32 min_def word_bits_def word_size_def)
  done

lemmas word32_minus_one_le' = word_minus_one_le[where 'a=32]
lemmas word32_minus_one_le = word32_minus_one_le'[simplified]

lemma ucast_not_helper:
  fixes a::word8
  assumes a: "a \<noteq> 0xFF"
  shows "ucast a \<noteq> (0xFF::word32)"
proof
  assume "ucast a = (0xFF::word32)"
  also
  have "(0xFF::word32) = ucast (0xFF::word8)" by simp
  finally
  show False using a
    apply -
    apply (drule up_ucast_inj, simp)
    apply simp
    done
qed

lemma less_4_cases:
  "(x::word32) < 4 \<Longrightarrow> x=0 \<or> x=1 \<or> x=2 \<or> x=3"
  apply clarsimp
  apply (drule word_less_cases, erule disjE, simp, simp)+
  done

lemma unat_ucast_8_32:
  fixes x :: "word8"
  shows "unat (ucast x :: word32) = unat x"
  unfolding ucast_def unat_def
  apply (subst int_word_uint)
  apply (subst mod_pos_pos_trivial)
    apply simp
   apply (rule lt2p_lem)
   apply simp
  apply simp
  done

lemma if_then_1_else_0:
  "((if P then 1 else 0) = (0 :: word32)) = (\<not> P)"
  by simp

lemma if_then_0_else_1:
  "((if P then 0 else 1) = (0 :: word32)) = (P)"
  by simp

lemmas if_then_simps = if_then_0_else_1 if_then_1_else_0

lemma ucast_le_ucast_8_32:
  "(ucast x \<le> (ucast y :: word32)) = (x \<le> (y :: word8))"
  by (simp add: ucast_le_ucast)

lemma in_16_range:
  "0 \<in> S \<Longrightarrow> r \<in> (\<lambda>x. r + x * (16 :: word32)) ` S"
  "n - 1 \<in> S \<Longrightarrow> (r + (16 * n - 16)) \<in> (\<lambda>x :: word32. r + x * 16) ` S"
  by (clarsimp simp: image_def elim!: bexI[rotated])+

lemma eq_2_32_0:
  "(2 ^ 32 :: word32) = 0"
  by simp

lemma x_less_2_0_1:
  fixes x :: word32 shows
  "x < 2 \<Longrightarrow> x = 0 \<or> x = 1"
  by (rule x_less_2_0_1') auto

lemmas mask_32_max_word  = max_word_mask [symmetric, where 'a=32, simplified]

lemma of_nat32_n_less_equal_power_2:
 "n < 32 \<Longrightarrow> ((of_nat n)::32 word) < 2 ^ n"
  by (rule of_nat_n_less_equal_power_2, clarsimp simp: word_size)

lemma word_rsplit_0:
  "word_rsplit (0 :: word32) = [0, 0, 0, 0 :: word8]"
  apply (simp add: word_rsplit_def bin_rsplit_def Let_def)
  done

lemma unat_ucast_10_32 :
  fixes x :: "10 word"
  shows "unat (ucast x :: word32) = unat x"
  unfolding ucast_def unat_def
  apply (subst int_word_uint)
  apply (subst mod_pos_pos_trivial)
    apply simp
   apply (rule lt2p_lem)
   apply simp
  apply simp
  done

lemma bool_mask [simp]:
  fixes x :: word32
  shows "(0 < x && 1) = (x && 1 = 1)"
  by (rule bool_mask') auto

lemma word32_bounds:
  "- (2 ^ (size (x :: word32) - 1)) = (-2147483648 :: int)"
  "((2 ^ (size (x :: word32) - 1)) - 1) = (2147483647 :: int)"
  "- (2 ^ (size (y :: 32 signed word) - 1)) = (-2147483648 :: int)"
  "((2 ^ (size (y :: 32 signed word) - 1)) - 1) = (2147483647 :: int)"
  by (simp_all add: word_size)

lemma word_ge_min:"sint (x::32 word) \<ge> -2147483648"
  by (metis sint_ge word32_bounds(1) word_size)

lemmas signed_arith_ineq_checks_to_eq_word32'
    = signed_arith_ineq_checks_to_eq[where 'a=32]
      signed_arith_ineq_checks_to_eq[where 'a="32 signed"]

lemmas signed_arith_ineq_checks_to_eq_word32
    = signed_arith_ineq_checks_to_eq_word32' [unfolded word32_bounds]

lemmas signed_mult_eq_checks32_to_64'
    = signed_mult_eq_checks_double_size[where 'a=32 and 'b=64]
      signed_mult_eq_checks_double_size[where 'a="32 signed" and 'b=64]

lemmas signed_mult_eq_checks32_to_64 = signed_mult_eq_checks32_to_64'[simplified]

lemmas sdiv_word32_max' = sdiv_word_max [where 'a=32] sdiv_word_max [where 'a="32 signed"]
lemmas sdiv_word32_max = sdiv_word32_max'[simplified word_size, simplified]

lemmas sdiv_word32_min' = sdiv_word_min [where 'a=32] sdiv_word_min [where 'a="32 signed"]
lemmas sdiv_word32_min = sdiv_word32_min' [simplified word_size, simplified]

lemmas sint32_of_int_eq' = sint_of_int_eq [where 'a=32]
lemmas sint32_of_int_eq = sint32_of_int_eq' [simplified]

lemma ucast_of_nats [simp]:
  "(ucast (of_nat x :: word32) :: sword32) = (of_nat x)"
  "(ucast (of_nat x :: word32) :: sword16) = (of_nat x)"
  "(ucast (of_nat x :: word32) :: sword8) = (of_nat x)"
  "(ucast (of_nat x :: word16) :: sword16) = (of_nat x)"
  "(ucast (of_nat x :: word16) :: sword8) = (of_nat x)"
  "(ucast (of_nat x :: word8) :: sword8) = (of_nat x)"
  by (auto simp: ucast_of_nat is_down)

lemmas signed_shift_guard_simpler_32'
    = power_strict_increasing_iff[where b="2 :: nat" and y=31]
lemmas signed_shift_guard_simpler_32 = signed_shift_guard_simpler_32'[simplified]

lemma word32_31_less:
  "31 < len_of TYPE (32 signed)" "31 > (0 :: nat)"
  "31 < len_of TYPE (32)" "31 > (0 :: nat)"
  by auto

lemmas signed_shift_guard_to_word_32
    = signed_shift_guard_to_word[OF word32_31_less(1-2)]
    signed_shift_guard_to_word[OF word32_31_less(3-4)]

lemma le_step_down_word_3:
  fixes x :: "32 word"
  shows "\<lbrakk>x \<le>  y; x \<noteq> y; y < 2 ^ 32 - 1\<rbrakk> \<Longrightarrow> x \<le> y - 1"
  by (rule le_step_down_word_2, assumption+)

lemma shiftr_1:
  "(x::word32) >> 1 = 0 \<Longrightarrow> x < 2"
  by word_bitwise clarsimp

lemma has_zero_byte:
  "~~ (((((v::word32) && 0x7f7f7f7f) + 0x7f7f7f7f) || v) || 0x7f7f7f7f) \<noteq> 0
    \<Longrightarrow> v && 0xff000000 = 0 \<or> v && 0xff0000 = 0 \<or> v && 0xff00 = 0 \<or> v && 0xff = 0"
  apply clarsimp
  apply word_bitwise
  by metis

lemma mask_step_down_32:
  "(b::32word) && 0x1 = (1::32word) \<Longrightarrow> (\<exists>x. x < 32 \<and> mask x = b >> 1) \<Longrightarrow> (\<exists>x. mask x = b)"
  apply clarsimp
  apply (rule_tac x="x + 1" in exI)
  apply (subgoal_tac "x \<le> 31")
   apply (erule le_step_down_nat, clarsimp simp:mask_def, word_bitwise, clarsimp+)+
   apply (clarsimp simp:mask_def, word_bitwise, clarsimp)
  apply clarsimp
  done

lemma unat_of_int_32:
  "\<lbrakk>i \<ge> 0; i \<le>2 ^ 31\<rbrakk> \<Longrightarrow> (unat ((of_int i)::sword32)) = nat i"
  unfolding unat_def
  apply (subst eq_nat_nat_iff, clarsimp+)
  apply (simp add: word_of_int uint_word_of_int)
  done

lemmas word_ctz_not_minus_1_32 = word_ctz_not_minus_1[where 'a=32, simplified]

(* Helper for packing then unpacking a 64-bit variable. *)
lemma cast_chunk_assemble_id_64[simp]:
  "(((ucast ((ucast (x::64 word))::32 word))::64 word) || (((ucast ((ucast (x >> 32))::32 word))::64 word) << 32)) = x"
  by (simp add:cast_chunk_assemble_id)

(* Another variant of packing and unpacking a 64-bit variable. *)
lemma cast_chunk_assemble_id_64'[simp]:
  "(((ucast ((scast (x::64 word))::32 word))::64 word) || (((ucast ((scast (x >> 32))::32 word))::64 word) << 32)) = x"
  by (simp add:cast_chunk_scast_assemble_id)

(* Specialisations of down_cast_same for adding to local simpsets. *)
lemma cast_down_u64: "(scast::64 word \<Rightarrow> 32 word) = (ucast::64 word \<Rightarrow> 32 word)"
  apply (subst down_cast_same[symmetric])
   apply (simp add:is_down)+
  done

lemma cast_down_s64: "(scast::64 sword \<Rightarrow> 32 word) = (ucast::64 sword \<Rightarrow> 32 word)"
  apply (subst down_cast_same[symmetric])
   apply (simp add:is_down)+
  done

end