(*  Title:      HOL/Statespace/DistinctTreeProver.thy
    Author:     Norbert Schirmer, TU Muenchen
*)

section \<open>Distinctness of Names in a Binary Tree \label{sec:DistinctTreeProver}\<close>

theory DistinctTreeProver
imports MainRLT
begin

text \<open>A state space manages a set of (abstract) names and assumes
that the names are distinct. The names are stored as parameters of a
locale and distinctness as an assumption. The most common request is
to proof distinctness of two given names. We maintain the names in a
balanced binary tree and formulate a predicate that all nodes in the
tree have distinct names. This setup leads to logarithmic certificates.
\<close>

subsection \<open>The Binary Tree\<close>

datatype 'a tree = Node "'a tree" 'a bool "'a tree" | Tip

text \<open>The boolean flag in the node marks the content of the node as
deleted, without having to build a new tree. We prefer the boolean
flag to an option type, so that the ML-layer can still use the node
content to facilitate binary search in the tree. The ML code keeps the
nodes sorted using the term order. We do not have to push ordering to
the HOL level.\<close>

subsection \<open>Distinctness of Nodes\<close>

primrec set_of :: "'a tree \<Rightarrow> 'a set"
where
  "set_of Tip = {}"
| "set_of (Node l x d r) = (if d then {} else {x}) \<union> set_of l \<union> set_of r"

primrec all_distinct :: "'a tree \<Rightarrow> bool"
where
  "all_distinct Tip = True"
| "all_distinct (Node l x d r) =
    ((d \<or> (x \<notin> set_of l \<and> x \<notin> set_of r)) \<and>
      set_of l \<inter> set_of r = {} \<and>
      all_distinct l \<and> all_distinct r)"

text \<open>Given a binary tree \<^term>\<open>t\<close> for which
\<^const>\<open>all_distinct\<close> holds, given two different nodes contained in the tree,
we want to write a ML function that generates a logarithmic
certificate that the content of the nodes is distinct. We use the
following lemmas to achieve this.\<close>

lemma all_distinct_left: "all_distinct (Node l x b r) \<Longrightarrow> all_distinct l"
  by simp

lemma all_distinct_right: "all_distinct (Node l x b r) \<Longrightarrow> all_distinct r"
  by simp

lemma distinct_left: "all_distinct (Node l x False r) \<Longrightarrow> y \<in> set_of l \<Longrightarrow> x \<noteq> y"
  by auto

lemma distinct_right: "all_distinct (Node l x False r) \<Longrightarrow> y \<in> set_of r \<Longrightarrow> x \<noteq> y"
  by auto

lemma distinct_left_right:
    "all_distinct (Node l z b r) \<Longrightarrow> x \<in> set_of l \<Longrightarrow> y \<in> set_of r \<Longrightarrow> x \<noteq> y"
  by auto

lemma in_set_root: "x \<in> set_of (Node l x False r)"
  by simp

lemma in_set_left: "y \<in> set_of l \<Longrightarrow>  y \<in> set_of (Node l x False r)"
  by simp

lemma in_set_right: "y \<in> set_of r \<Longrightarrow>  y \<in> set_of (Node l x False r)"
  by simp

lemma swap_neq: "x \<noteq> y \<Longrightarrow> y \<noteq> x"
  by blast

lemma neq_to_eq_False: "x\<noteq>y \<Longrightarrow> (x=y)\<equiv>False"
  by simp

subsection \<open>Containment of Trees\<close>

text \<open>When deriving a state space from other ones, we create a new
name tree which contains all the names of the parent state spaces and
assume the predicate \<^const>\<open>all_distinct\<close>. We then prove that the new
locale interprets all parent locales. Hence we have to show that the
new distinctness assumption on all names implies the distinctness
assumptions of the parent locales. This proof is implemented in ML. We
do this efficiently by defining a kind of containment check of trees
by ``subtraction''.  We subtract the parent tree from the new tree. If
this succeeds we know that \<^const>\<open>all_distinct\<close> of the new tree
implies \<^const>\<open>all_distinct\<close> of the parent tree.  The resulting
certificate is of the order \<^term>\<open>n * log(m)\<close> where \<^term>\<open>n\<close> is
the size of the (smaller) parent tree and \<^term>\<open>m\<close> the size of the
(bigger) new tree.\<close>

primrec delete :: "'a \<Rightarrow> 'a tree \<Rightarrow> 'a tree option"
where
  "delete x Tip = None"
| "delete x (Node l y d r) = (case delete x l of
                                Some l' \<Rightarrow>
                                 (case delete x r of
                                    Some r' \<Rightarrow> Some (Node l' y (d \<or> (x=y)) r')
                                  | None \<Rightarrow> Some (Node l' y (d \<or> (x=y)) r))
                               | None \<Rightarrow>
                                  (case delete x r of
                                     Some r' \<Rightarrow> Some (Node l y (d \<or> (x=y)) r')
                                   | None \<Rightarrow> if x=y \<and> \<not>d then Some (Node l y True r)
                                             else None))"

lemma delete_Some_set_of: "delete x t = Some t' \<Longrightarrow> set_of t' \<subseteq> set_of t"
proof (induct t arbitrary: t')
  case Tip thus ?case by simp
next
  case (Node l y d r)
  have del: "delete x (Node l y d r) = Some t'" by fact
  show ?case
  proof (cases "delete x l")
    case (Some l')
    note x_l_Some = this
    with Node.hyps
    have l'_l: "set_of l' \<subseteq> set_of l"
      by simp
    show ?thesis
    proof (cases "delete x r")
      case (Some r')
      with Node.hyps
      have "set_of r' \<subseteq> set_of r"
        by simp
      with l'_l Some x_l_Some del
      show ?thesis
        by (auto split: if_split_asm)
    next
      case None
      with l'_l Some x_l_Some del
      show ?thesis
        by (fastforce split: if_split_asm)
    qed
  next
    case None
    note x_l_None = this
    show ?thesis
    proof (cases "delete x r")
      case (Some r')
      with Node.hyps
      have "set_of r' \<subseteq> set_of r"
        by simp
      with Some x_l_None del
      show ?thesis
        by (fastforce split: if_split_asm)
    next
      case None
      with x_l_None del
      show ?thesis
        by (fastforce split: if_split_asm)
    qed
  qed
qed

lemma delete_Some_all_distinct:
  "delete x t = Some t' \<Longrightarrow> all_distinct t \<Longrightarrow> all_distinct t'"
proof (induct t arbitrary: t')
  case Tip thus ?case by simp
next
  case (Node l y d r)
  have del: "delete x (Node l y d r) = Some t'" by fact
  have "all_distinct (Node l y d r)" by fact
  then obtain
    dist_l: "all_distinct l" and
    dist_r: "all_distinct r" and
    d: "d \<or> (y \<notin> set_of l \<and> y \<notin> set_of r)" and
    dist_l_r: "set_of l \<inter> set_of r = {}"
    by auto
  show ?case
  proof (cases "delete x l")
    case (Some l')
    note x_l_Some = this
    from Node.hyps (1) [OF Some dist_l]
    have dist_l': "all_distinct l'"
      by simp
    from delete_Some_set_of [OF x_l_Some]
    have l'_l: "set_of l' \<subseteq> set_of l".
    show ?thesis
    proof (cases "delete x r")
      case (Some r')
      from Node.hyps (2) [OF Some dist_r]
      have dist_r': "all_distinct r'"
        by simp
      from delete_Some_set_of [OF Some]
      have "set_of r' \<subseteq> set_of r".

      with dist_l' dist_r' l'_l Some x_l_Some del d dist_l_r
      show ?thesis
        by fastforce
    next
      case None
      with l'_l dist_l'  x_l_Some del d dist_l_r dist_r
      show ?thesis
        by fastforce
    qed
  next
    case None
    note x_l_None = this
    show ?thesis
    proof (cases "delete x r")
      case (Some r')
      with Node.hyps (2) [OF Some dist_r]
      have dist_r': "all_distinct r'"
        by simp
      from delete_Some_set_of [OF Some]
      have "set_of r' \<subseteq> set_of r".
      with Some dist_r' x_l_None del dist_l d dist_l_r
      show ?thesis
        by fastforce
    next
      case None
      with x_l_None del dist_l dist_r d dist_l_r
      show ?thesis
        by (fastforce split: if_split_asm)
    qed
  qed
qed

lemma delete_None_set_of_conv: "delete x t = None = (x \<notin> set_of t)"
proof (induct t)
  case Tip thus ?case by simp
next
  case (Node l y d r)
  thus ?case
    by (auto split: option.splits)
qed

lemma delete_Some_x_set_of:
  "delete x t = Some t' \<Longrightarrow> x \<in> set_of t \<and> x \<notin> set_of t'"
proof (induct t arbitrary: t')
  case Tip thus ?case by simp
next
  case (Node l y d r)
  have del: "delete x (Node l y d r) = Some t'" by fact
  show ?case
  proof (cases "delete x l")
    case (Some l')
    note x_l_Some = this
    from Node.hyps (1) [OF Some]
    obtain x_l: "x \<in> set_of l" "x \<notin> set_of l'"
      by simp
    show ?thesis
    proof (cases "delete x r")
      case (Some r')
      from Node.hyps (2) [OF Some]
      obtain x_r: "x \<in> set_of r" "x \<notin> set_of r'"
        by simp
      from x_r x_l Some x_l_Some del
      show ?thesis
        by (clarsimp split: if_split_asm)
    next
      case None
      then have "x \<notin> set_of r"
        by (simp add: delete_None_set_of_conv)
      with x_l None x_l_Some del
      show ?thesis
        by (clarsimp split: if_split_asm)
    qed
  next
    case None
    note x_l_None = this
    then have x_notin_l: "x \<notin> set_of l"
      by (simp add: delete_None_set_of_conv)
    show ?thesis
    proof (cases "delete x r")
      case (Some r')
      from Node.hyps (2) [OF Some]
      obtain x_r: "x \<in> set_of r" "x \<notin> set_of r'"
        by simp
      from x_r x_notin_l Some x_l_None del
      show ?thesis
        by (clarsimp split: if_split_asm)
    next
      case None
      then have "x \<notin> set_of r"
        by (simp add: delete_None_set_of_conv)
      with None x_l_None x_notin_l del
      show ?thesis
        by (clarsimp split: if_split_asm)
    qed
  qed
qed

primrec subtract :: "'a tree \<Rightarrow> 'a tree \<Rightarrow> 'a tree option"
where
  "subtract Tip t = Some t"
| "subtract (Node l x b r) t =
     (case delete x t of
        Some t' \<Rightarrow> (case subtract l t' of
                     Some t'' \<Rightarrow> subtract r t''
                    | None \<Rightarrow> None)
       | None \<Rightarrow> None)"

lemma subtract_Some_set_of_res:
  "subtract t\<^sub>1 t\<^sub>2 = Some t \<Longrightarrow> set_of t \<subseteq> set_of t\<^sub>2"
proof (induct t\<^sub>1 arbitrary: t\<^sub>2 t)
  case Tip thus ?case by simp
next
  case (Node l x b r)
  have sub: "subtract (Node l x b r) t\<^sub>2 = Some t" by fact
  show ?case
  proof (cases "delete x t\<^sub>2")
    case (Some t\<^sub>2')
    note del_x_Some = this
    from delete_Some_set_of [OF Some]
    have t2'_t2: "set_of t\<^sub>2' \<subseteq> set_of t\<^sub>2" .
    show ?thesis
    proof (cases "subtract l t\<^sub>2'")
      case (Some t\<^sub>2'')
      note sub_l_Some = this
      from Node.hyps (1) [OF Some]
      have t2''_t2': "set_of t\<^sub>2'' \<subseteq> set_of t\<^sub>2'" .
      show ?thesis
      proof (cases "subtract r t\<^sub>2''")
        case (Some t\<^sub>2''')
        from Node.hyps (2) [OF Some ]
        have "set_of t\<^sub>2''' \<subseteq> set_of t\<^sub>2''" .
        with Some sub_l_Some del_x_Some sub t2''_t2' t2'_t2
        show ?thesis
          by simp
      next
        case None
        with del_x_Some sub_l_Some sub
        show ?thesis
          by simp
      qed
    next
      case None
      with del_x_Some sub
      show ?thesis
        by simp
    qed
  next
    case None
    with sub show ?thesis by simp
  qed
qed

lemma subtract_Some_set_of:
  "subtract t\<^sub>1 t\<^sub>2 = Some t \<Longrightarrow> set_of t\<^sub>1 \<subseteq> set_of t\<^sub>2"
proof (induct t\<^sub>1 arbitrary: t\<^sub>2 t)
  case Tip thus ?case by simp
next
  case (Node l x d r)
  have sub: "subtract (Node l x d r) t\<^sub>2 = Some t" by fact
  show ?case
  proof (cases "delete x t\<^sub>2")
    case (Some t\<^sub>2')
    note del_x_Some = this
    from delete_Some_set_of [OF Some]
    have t2'_t2: "set_of t\<^sub>2' \<subseteq> set_of t\<^sub>2" .
    from delete_None_set_of_conv [of x t\<^sub>2] Some
    have x_t2: "x \<in> set_of t\<^sub>2"
      by simp
    show ?thesis
    proof (cases "subtract l t\<^sub>2'")
      case (Some t\<^sub>2'')
      note sub_l_Some = this
      from Node.hyps (1) [OF Some]
      have l_t2': "set_of l \<subseteq> set_of t\<^sub>2'" .
      from subtract_Some_set_of_res [OF Some]
      have t2''_t2': "set_of t\<^sub>2'' \<subseteq> set_of t\<^sub>2'" .
      show ?thesis
      proof (cases "subtract r t\<^sub>2''")
        case (Some t\<^sub>2''')
        from Node.hyps (2) [OF Some ]
        have r_t\<^sub>2'': "set_of r \<subseteq> set_of t\<^sub>2''" .
        from Some sub_l_Some del_x_Some sub r_t\<^sub>2'' l_t2' t2'_t2 t2''_t2' x_t2
        show ?thesis
          by auto
      next
        case None
        with del_x_Some sub_l_Some sub
        show ?thesis
          by simp
      qed
    next
      case None
      with del_x_Some sub
      show ?thesis
        by simp
    qed
  next
    case None
    with sub show ?thesis by simp
  qed
qed

lemma subtract_Some_all_distinct_res:
  "subtract t\<^sub>1 t\<^sub>2 = Some t \<Longrightarrow> all_distinct t\<^sub>2 \<Longrightarrow> all_distinct t"
proof (induct t\<^sub>1 arbitrary: t\<^sub>2 t)
  case Tip thus ?case by simp
next
  case (Node l x d r)
  have sub: "subtract (Node l x d r) t\<^sub>2 = Some t" by fact
  have dist_t2: "all_distinct t\<^sub>2" by fact
  show ?case
  proof (cases "delete x t\<^sub>2")
    case (Some t\<^sub>2')
    note del_x_Some = this
    from delete_Some_all_distinct [OF Some dist_t2]
    have dist_t2': "all_distinct t\<^sub>2'" .
    show ?thesis
    proof (cases "subtract l t\<^sub>2'")
      case (Some t\<^sub>2'')
      note sub_l_Some = this
      from Node.hyps (1) [OF Some dist_t2']
      have dist_t2'': "all_distinct t\<^sub>2''" .
      show ?thesis
      proof (cases "subtract r t\<^sub>2''")
        case (Some t\<^sub>2''')
        from Node.hyps (2) [OF Some dist_t2'']
        have dist_t2''': "all_distinct t\<^sub>2'''" .
        from Some sub_l_Some del_x_Some sub
             dist_t2'''
        show ?thesis
          by simp
      next
        case None
        with del_x_Some sub_l_Some sub
        show ?thesis
          by simp
      qed
    next
      case None
      with del_x_Some sub
      show ?thesis
        by simp
    qed
  next
    case None
    with sub show ?thesis by simp
  qed
qed

lemma subtract_Some_dist_res:
  "subtract t\<^sub>1 t\<^sub>2 = Some t \<Longrightarrow> set_of t\<^sub>1 \<inter> set_of t = {}"
proof (induct t\<^sub>1 arbitrary: t\<^sub>2 t)
  case Tip thus ?case by simp
next
  case (Node l x d r)
  have sub: "subtract (Node l x d r) t\<^sub>2 = Some t" by fact
  show ?case
  proof (cases "delete x t\<^sub>2")
    case (Some t\<^sub>2')
    note del_x_Some = this
    from delete_Some_x_set_of [OF Some]
    obtain x_t2: "x \<in> set_of t\<^sub>2" and x_not_t2': "x \<notin> set_of t\<^sub>2'"
      by simp
    from delete_Some_set_of [OF Some]
    have t2'_t2: "set_of t\<^sub>2' \<subseteq> set_of t\<^sub>2" .
    show ?thesis
    proof (cases "subtract l t\<^sub>2'")
      case (Some t\<^sub>2'')
      note sub_l_Some = this
      from Node.hyps (1) [OF Some ]
      have dist_l_t2'': "set_of l \<inter> set_of t\<^sub>2'' = {}".
      from subtract_Some_set_of_res [OF Some]
      have t2''_t2': "set_of t\<^sub>2'' \<subseteq> set_of t\<^sub>2'" .
      show ?thesis
      proof (cases "subtract r t\<^sub>2''")
        case (Some t\<^sub>2''')
        from Node.hyps (2) [OF Some]
        have dist_r_t2''': "set_of r \<inter> set_of t\<^sub>2''' = {}" .
        from subtract_Some_set_of_res [OF Some]
        have t2'''_t2'': "set_of t\<^sub>2''' \<subseteq> set_of t\<^sub>2''".

        from Some sub_l_Some del_x_Some sub t2'''_t2'' dist_l_t2'' dist_r_t2'''
             t2''_t2' t2'_t2 x_not_t2'
        show ?thesis
          by auto
      next
        case None
        with del_x_Some sub_l_Some sub
        show ?thesis
          by simp
      qed
    next
      case None
      with del_x_Some sub
      show ?thesis
        by simp
    qed
  next
    case None
    with sub show ?thesis by simp
  qed
qed

lemma subtract_Some_all_distinct:
  "subtract t\<^sub>1 t\<^sub>2 = Some t \<Longrightarrow> all_distinct t\<^sub>2 \<Longrightarrow> all_distinct t\<^sub>1"
proof (induct t\<^sub>1 arbitrary: t\<^sub>2 t)
  case Tip thus ?case by simp
next
  case (Node l x d r)
  have sub: "subtract (Node l x d r) t\<^sub>2 = Some t" by fact
  have dist_t2: "all_distinct t\<^sub>2" by fact
  show ?case
  proof (cases "delete x t\<^sub>2")
    case (Some t\<^sub>2')
    note del_x_Some = this
    from delete_Some_all_distinct [OF Some dist_t2 ]
    have dist_t2': "all_distinct t\<^sub>2'" .
    from delete_Some_set_of [OF Some]
    have t2'_t2: "set_of t\<^sub>2' \<subseteq> set_of t\<^sub>2" .
    from delete_Some_x_set_of [OF Some]
    obtain x_t2: "x \<in> set_of t\<^sub>2" and x_not_t2': "x \<notin> set_of t\<^sub>2'"
      by simp

    show ?thesis
    proof (cases "subtract l t\<^sub>2'")
      case (Some t\<^sub>2'')
      note sub_l_Some = this
      from Node.hyps (1) [OF Some dist_t2' ]
      have dist_l: "all_distinct l" .
      from subtract_Some_all_distinct_res [OF Some dist_t2']
      have dist_t2'': "all_distinct t\<^sub>2''" .
      from subtract_Some_set_of [OF Some]
      have l_t2': "set_of l \<subseteq> set_of t\<^sub>2'" .
      from subtract_Some_set_of_res [OF Some]
      have t2''_t2': "set_of t\<^sub>2'' \<subseteq> set_of t\<^sub>2'" .
      from subtract_Some_dist_res [OF Some]
      have dist_l_t2'': "set_of l \<inter> set_of t\<^sub>2'' = {}".
      show ?thesis
      proof (cases "subtract r t\<^sub>2''")
        case (Some t\<^sub>2''')
        from Node.hyps (2) [OF Some dist_t2'']
        have dist_r: "all_distinct r" .
        from subtract_Some_set_of [OF Some]
        have r_t2'': "set_of r \<subseteq> set_of t\<^sub>2''" .
        from subtract_Some_dist_res [OF Some]
        have dist_r_t2''': "set_of r \<inter> set_of t\<^sub>2''' = {}".

        from dist_l dist_r Some sub_l_Some del_x_Some r_t2'' l_t2' x_t2 x_not_t2'
             t2''_t2' dist_l_t2'' dist_r_t2'''
        show ?thesis
          by auto
      next
        case None
        with del_x_Some sub_l_Some sub
        show ?thesis
          by simp
      qed
    next
      case None
      with del_x_Some sub
      show ?thesis
        by simp
    qed
  next
    case None
    with sub show ?thesis by simp
  qed
qed

lemma delete_left:
  assumes dist: "all_distinct (Node l y d r)"
  assumes del_l: "delete x l = Some l'"
  shows "delete x (Node l y d r) = Some (Node l' y d r)"
proof -
  from delete_Some_x_set_of [OF del_l]
  obtain x: "x \<in> set_of l"
    by simp
  with dist
  have "delete x r = None"
    by (cases "delete x r") (auto dest:delete_Some_x_set_of)

  with x
  show ?thesis
    using del_l dist
    by (auto split: option.splits)
qed

lemma delete_right:
  assumes dist: "all_distinct (Node l y d r)"
  assumes del_r: "delete x r = Some r'"
  shows "delete x (Node l y d r) = Some (Node l y d r')"
proof -
  from delete_Some_x_set_of [OF del_r]
  obtain x: "x \<in> set_of r"
    by simp
  with dist
  have "delete x l = None"
    by (cases "delete x l") (auto dest:delete_Some_x_set_of)

  with x
  show ?thesis
    using del_r dist
    by (auto split: option.splits)
qed

lemma delete_root:
  assumes dist: "all_distinct (Node l x False r)"
  shows "delete x (Node l x False r) = Some (Node l x True r)"
proof -
  from dist have "delete x r = None"
    by (cases "delete x r") (auto dest:delete_Some_x_set_of)
  moreover
  from dist have "delete x l = None"
    by (cases "delete x l") (auto dest:delete_Some_x_set_of)
  ultimately show ?thesis
    using dist
       by (auto split: option.splits)
qed

lemma subtract_Node:
 assumes del: "delete x t = Some t'"
 assumes sub_l: "subtract l t' = Some t''"
 assumes sub_r: "subtract r t'' = Some t'''"
 shows "subtract (Node l x False r) t = Some t'''"
using del sub_l sub_r
by simp

lemma subtract_Tip: "subtract Tip t = Some t"
  by simp

text \<open>Now we have all the theorems in place that are needed for the
certificate generating ML functions.\<close>

ML_file \<open>distinct_tree_prover.ML\<close>

end


(*
  Author: Jeremy Dawson and Gerwin Klein, NICTA

  Definitions and basic theorems for bit-wise logical operations
  for integers expressed using Pls, Min, BIT,
  and converting them to and from lists of bools.
*)

section {* Bitwise Operations on Binary Integers *}

theory Bits_Int
imports Bits Bit_Representation
begin

subsection {* Logical operations *}

text "bit-wise logical operations on the int type"

instantiation int :: bit
begin

definition int_not_def:
  "bitNOT = (\<lambda>x::int. - x - 1)"

function bitAND_int where
  "bitAND_int x y =
    (if x = 0 then 0 else if x = -1 then y else
      (bin_rest x AND bin_rest y) BIT (bin_last x \<and> bin_last y))"
  by pat_completeness simp

termination
  by (relation "measure (nat o abs o fst)", simp_all add: bin_rest_def)

declare bitAND_int.simps [simp del]

definition int_or_def:
  "bitOR = (\<lambda>x y::int. NOT (NOT x AND NOT y))"

definition int_xor_def:
  "bitXOR = (\<lambda>x y::int. (x AND NOT y) OR (NOT x AND y))"

instance ..

end

subsubsection {* Basic simplification rules *}

lemma int_not_BIT [simp]:
  "NOT (w BIT b) = (NOT w) BIT (\<not> b)"
  unfolding int_not_def Bit_def by (cases b, simp_all)

lemma int_not_simps [simp]:
  "NOT (0::int) = -1"
  "NOT (1::int) = -2"
  "NOT (- 1::int) = 0"
  "NOT (numeral w::int) = - numeral (w + Num.One)"
  "NOT (- numeral (Num.Bit0 w)::int) = numeral (Num.BitM w)"
  "NOT (- numeral (Num.Bit1 w)::int) = numeral (Num.Bit0 w)"
  unfolding int_not_def by simp_all

lemma int_not_not [simp]: "NOT (NOT (x::int)) = x"
  unfolding int_not_def by simp

lemma int_and_0 [simp]: "(0::int) AND x = 0"
  by (simp add: bitAND_int.simps)

lemma int_and_m1 [simp]: "(-1::int) AND x = x"
  by (simp add: bitAND_int.simps)

lemma int_and_Bits [simp]:
  "(x BIT b) AND (y BIT c) = (x AND y) BIT (b \<and> c)"
  by (subst bitAND_int.simps, simp add: Bit_eq_0_iff Bit_eq_m1_iff)

lemma int_or_zero [simp]: "(0::int) OR x = x"
  unfolding int_or_def by simp

lemma int_or_minus1 [simp]: "(-1::int) OR x = -1"
  unfolding int_or_def by simp

lemma int_or_Bits [simp]:
  "(x BIT b) OR (y BIT c) = (x OR y) BIT (b \<or> c)"
  unfolding int_or_def by simp

lemma int_xor_zero [simp]: "(0::int) XOR x = x"
  unfolding int_xor_def by simp

lemma int_xor_Bits [simp]:
  "(x BIT b) XOR (y BIT c) = (x XOR y) BIT ((b \<or> c) \<and> \<not> (b \<and> c))"
  unfolding int_xor_def by auto

subsubsection {* Binary destructors *}

lemma bin_rest_NOT [simp]: "bin_rest (NOT x) = NOT (bin_rest x)"
  by (cases x rule: bin_exhaust, simp)

lemma bin_last_NOT [simp]: "bin_last (NOT x) \<longleftrightarrow> \<not> bin_last x"
  by (cases x rule: bin_exhaust, simp)

lemma bin_rest_AND [simp]: "bin_rest (x AND y) = bin_rest x AND bin_rest y"
  by (cases x rule: bin_exhaust, cases y rule: bin_exhaust, simp)

lemma bin_last_AND [simp]: "bin_last (x AND y) \<longleftrightarrow> bin_last x \<and> bin_last y"
  by (cases x rule: bin_exhaust, cases y rule: bin_exhaust, simp)

lemma bin_rest_OR [simp]: "bin_rest (x OR y) = bin_rest x OR bin_rest y"
  by (cases x rule: bin_exhaust, cases y rule: bin_exhaust, simp)

lemma bin_last_OR [simp]: "bin_last (x OR y) \<longleftrightarrow> bin_last x \<or> bin_last y"
  by (cases x rule: bin_exhaust, cases y rule: bin_exhaust, simp)

lemma bin_rest_XOR [simp]: "bin_rest (x XOR y) = bin_rest x XOR bin_rest y"
  by (cases x rule: bin_exhaust, cases y rule: bin_exhaust, simp)

lemma bin_last_XOR [simp]: "bin_last (x XOR y) \<longleftrightarrow> (bin_last x \<or> bin_last y) \<and> \<not> (bin_last x \<and> bin_last y)"
  by (cases x rule: bin_exhaust, cases y rule: bin_exhaust, simp)

lemma bin_nth_ops:
  "!!x y. bin_nth (x AND y) n = (bin_nth x n & bin_nth y n)"
  "!!x y. bin_nth (x OR y) n = (bin_nth x n | bin_nth y n)"
  "!!x y. bin_nth (x XOR y) n = (bin_nth x n ~= bin_nth y n)"
  "!!x. bin_nth (NOT x) n = (~ bin_nth x n)"
  by (induct n) auto

subsubsection {* Derived properties *}

lemma int_xor_minus1 [simp]: "(-1::int) XOR x = NOT x"
  by (auto simp add: bin_eq_iff bin_nth_ops)

lemma int_xor_extra_simps [simp]:
  "w XOR (0::int) = w"
  "w XOR (-1::int) = NOT w"
  by (auto simp add: bin_eq_iff bin_nth_ops)

lemma int_or_extra_simps [simp]:
  "w OR (0::int) = w"
  "w OR (-1::int) = -1"
  by (auto simp add: bin_eq_iff bin_nth_ops)

lemma int_and_extra_simps [simp]:
  "w AND (0::int) = 0"
  "w AND (-1::int) = w"
  by (auto simp add: bin_eq_iff bin_nth_ops)

(* commutativity of the above *)
lemma bin_ops_comm:
  shows
  int_and_comm: "!!y::int. x AND y = y AND x" and
  int_or_comm:  "!!y::int. x OR y = y OR x" and
  int_xor_comm: "!!y::int. x XOR y = y XOR x"
  by (auto simp add: bin_eq_iff bin_nth_ops)

lemma bin_ops_same [simp]:
  "(x::int) AND x = x"
  "(x::int) OR x = x"
  "(x::int) XOR x = 0"
  by (auto simp add: bin_eq_iff bin_nth_ops)

lemmas bin_log_esimps =
  int_and_extra_simps  int_or_extra_simps  int_xor_extra_simps
  int_and_0 int_and_m1 int_or_zero int_or_minus1 int_xor_zero int_xor_minus1

(* basic properties of logical (bit-wise) operations *)

lemma bbw_ao_absorb:
  "!!y::int. x AND (y OR x) = x & x OR (y AND x) = x"
  by (auto simp add: bin_eq_iff bin_nth_ops)

lemma bbw_ao_absorbs_other:
  "x AND (x OR y) = x \<and> (y AND x) OR x = (x::int)"
  "(y OR x) AND x = x \<and> x OR (x AND y) = (x::int)"
  "(x OR y) AND x = x \<and> (x AND y) OR x = (x::int)"
  by (auto simp add: bin_eq_iff bin_nth_ops)

lemmas bbw_ao_absorbs [simp] = bbw_ao_absorb bbw_ao_absorbs_other

lemma int_xor_not:
  "!!y::int. (NOT x) XOR y = NOT (x XOR y) &
        x XOR (NOT y) = NOT (x XOR y)"
  by (auto simp add: bin_eq_iff bin_nth_ops)

lemma int_and_assoc:
  "(x AND y) AND (z::int) = x AND (y AND z)"
  by (auto simp add: bin_eq_iff bin_nth_ops)

lemma int_or_assoc:
  "(x OR y) OR (z::int) = x OR (y OR z)"
  by (auto simp add: bin_eq_iff bin_nth_ops)

lemma int_xor_assoc:
  "(x XOR y) XOR (z::int) = x XOR (y XOR z)"
  by (auto simp add: bin_eq_iff bin_nth_ops)

lemmas bbw_assocs = int_and_assoc int_or_assoc int_xor_assoc

(* BH: Why are these declared as simp rules??? *)
lemma bbw_lcs [simp]:
  "(y::int) AND (x AND z) = x AND (y AND z)"
  "(y::int) OR (x OR z) = x OR (y OR z)"
  "(y::int) XOR (x XOR z) = x XOR (y XOR z)"
  by (auto simp add: bin_eq_iff bin_nth_ops)

lemma bbw_not_dist:
  "!!y::int. NOT (x OR y) = (NOT x) AND (NOT y)"
  "!!y::int. NOT (x AND y) = (NOT x) OR (NOT y)"
  by (auto simp add: bin_eq_iff bin_nth_ops)

lemma bbw_oa_dist:
  "!!y z::int. (x AND y) OR z =
          (x OR z) AND (y OR z)"
  by (auto simp add: bin_eq_iff bin_nth_ops)

lemma bbw_ao_dist:
  "!!y z::int. (x OR y) AND z =
          (x AND z) OR (y AND z)"
  by (auto simp add: bin_eq_iff bin_nth_ops)

(*
Why were these declared simp???
declare bin_ops_comm [simp] bbw_assocs [simp]
*)

subsubsection {* Simplification with numerals *}

text {* Cases for @{text "0"} and @{text "-1"} are already covered by
  other simp rules. *}

lemma bin_rl_eqI: "\<lbrakk>bin_rest x = bin_rest y; bin_last x = bin_last y\<rbrakk> \<Longrightarrow> x = y"
  by (metis (mono_tags) BIT_eq_iff bin_ex_rl bin_last_BIT bin_rest_BIT)

lemma bin_rest_neg_numeral_BitM [simp]:
  "bin_rest (- numeral (Num.BitM w)) = - numeral w"
  by (simp only: BIT_bin_simps [symmetric] bin_rest_BIT)

lemma bin_last_neg_numeral_BitM [simp]:
  "bin_last (- numeral (Num.BitM w))"
  by (simp only: BIT_bin_simps [symmetric] bin_last_BIT)

text {* FIXME: The rule sets below are very large (24 rules for each
  operator). Is there a simpler way to do this? *}

lemma int_and_numerals [simp]:
  "numeral (Num.Bit0 x) AND numeral (Num.Bit0 y) = (numeral x AND numeral y) BIT False"
  "numeral (Num.Bit0 x) AND numeral (Num.Bit1 y) = (numeral x AND numeral y) BIT False"
  "numeral (Num.Bit1 x) AND numeral (Num.Bit0 y) = (numeral x AND numeral y) BIT False"
  "numeral (Num.Bit1 x) AND numeral (Num.Bit1 y) = (numeral x AND numeral y) BIT True"
  "numeral (Num.Bit0 x) AND - numeral (Num.Bit0 y) = (numeral x AND - numeral y) BIT False"
  "numeral (Num.Bit0 x) AND - numeral (Num.Bit1 y) = (numeral x AND - numeral (y + Num.One)) BIT False"
  "numeral (Num.Bit1 x) AND - numeral (Num.Bit0 y) = (numeral x AND - numeral y) BIT False"
  "numeral (Num.Bit1 x) AND - numeral (Num.Bit1 y) = (numeral x AND - numeral (y + Num.One)) BIT True"
  "- numeral (Num.Bit0 x) AND numeral (Num.Bit0 y) = (- numeral x AND numeral y) BIT False"
  "- numeral (Num.Bit0 x) AND numeral (Num.Bit1 y) = (- numeral x AND numeral y) BIT False"
  "- numeral (Num.Bit1 x) AND numeral (Num.Bit0 y) = (- numeral (x + Num.One) AND numeral y) BIT False"
  "- numeral (Num.Bit1 x) AND numeral (Num.Bit1 y) = (- numeral (x + Num.One) AND numeral y) BIT True"
  "- numeral (Num.Bit0 x) AND - numeral (Num.Bit0 y) = (- numeral x AND - numeral y) BIT False"
  "- numeral (Num.Bit0 x) AND - numeral (Num.Bit1 y) = (- numeral x AND - numeral (y + Num.One)) BIT False"
  "- numeral (Num.Bit1 x) AND - numeral (Num.Bit0 y) = (- numeral (x + Num.One) AND - numeral y) BIT False"
  "- numeral (Num.Bit1 x) AND - numeral (Num.Bit1 y) = (- numeral (x + Num.One) AND - numeral (y + Num.One)) BIT True"
  "(1::int) AND numeral (Num.Bit0 y) = 0"
  "(1::int) AND numeral (Num.Bit1 y) = 1"
  "(1::int) AND - numeral (Num.Bit0 y) = 0"
  "(1::int) AND - numeral (Num.Bit1 y) = 1"
  "numeral (Num.Bit0 x) AND (1::int) = 0"
  "numeral (Num.Bit1 x) AND (1::int) = 1"
  "- numeral (Num.Bit0 x) AND (1::int) = 0"
  "- numeral (Num.Bit1 x) AND (1::int) = 1"
  by (rule bin_rl_eqI, simp, simp)+

lemma int_or_numerals [simp]:
  "numeral (Num.Bit0 x) OR numeral (Num.Bit0 y) = (numeral x OR numeral y) BIT False"
  "numeral (Num.Bit0 x) OR numeral (Num.Bit1 y) = (numeral x OR numeral y) BIT True"
  "numeral (Num.Bit1 x) OR numeral (Num.Bit0 y) = (numeral x OR numeral y) BIT True"
  "numeral (Num.Bit1 x) OR numeral (Num.Bit1 y) = (numeral x OR numeral y) BIT True"
  "numeral (Num.Bit0 x) OR - numeral (Num.Bit0 y) = (numeral x OR - numeral y) BIT False"
  "numeral (Num.Bit0 x) OR - numeral (Num.Bit1 y) = (numeral x OR - numeral (y + Num.One)) BIT True"
  "numeral (Num.Bit1 x) OR - numeral (Num.Bit0 y) = (numeral x OR - numeral y) BIT True"
  "numeral (Num.Bit1 x) OR - numeral (Num.Bit1 y) = (numeral x OR - numeral (y + Num.One)) BIT True"
  "- numeral (Num.Bit0 x) OR numeral (Num.Bit0 y) = (- numeral x OR numeral y) BIT False"
  "- numeral (Num.Bit0 x) OR numeral (Num.Bit1 y) = (- numeral x OR numeral y) BIT True"
  "- numeral (Num.Bit1 x) OR numeral (Num.Bit0 y) = (- numeral (x + Num.One) OR numeral y) BIT True"
  "- numeral (Num.Bit1 x) OR numeral (Num.Bit1 y) = (- numeral (x + Num.One) OR numeral y) BIT True"
  "- numeral (Num.Bit0 x) OR - numeral (Num.Bit0 y) = (- numeral x OR - numeral y) BIT False"
  "- numeral (Num.Bit0 x) OR - numeral (Num.Bit1 y) = (- numeral x OR - numeral (y + Num.One)) BIT True"
  "- numeral (Num.Bit1 x) OR - numeral (Num.Bit0 y) = (- numeral (x + Num.One) OR - numeral y) BIT True"
  "- numeral (Num.Bit1 x) OR - numeral (Num.Bit1 y) = (- numeral (x + Num.One) OR - numeral (y + Num.One)) BIT True"
  "(1::int) OR numeral (Num.Bit0 y) = numeral (Num.Bit1 y)"
  "(1::int) OR numeral (Num.Bit1 y) = numeral (Num.Bit1 y)"
  "(1::int) OR - numeral (Num.Bit0 y) = - numeral (Num.BitM y)"
  "(1::int) OR - numeral (Num.Bit1 y) = - numeral (Num.Bit1 y)"
  "numeral (Num.Bit0 x) OR (1::int) = numeral (Num.Bit1 x)"
  "numeral (Num.Bit1 x) OR (1::int) = numeral (Num.Bit1 x)"
  "- numeral (Num.Bit0 x) OR (1::int) = - numeral (Num.BitM x)"
  "- numeral (Num.Bit1 x) OR (1::int) = - numeral (Num.Bit1 x)"
  by (rule bin_rl_eqI, simp, simp)+

lemma int_xor_numerals [simp]:
  "numeral (Num.Bit0 x) XOR numeral (Num.Bit0 y) = (numeral x XOR numeral y) BIT False"
  "numeral (Num.Bit0 x) XOR numeral (Num.Bit1 y) = (numeral x XOR numeral y) BIT True"
  "numeral (Num.Bit1 x) XOR numeral (Num.Bit0 y) = (numeral x XOR numeral y) BIT True"
  "numeral (Num.Bit1 x) XOR numeral (Num.Bit1 y) = (numeral x XOR numeral y) BIT False"
  "numeral (Num.Bit0 x) XOR - numeral (Num.Bit0 y) = (numeral x XOR - numeral y) BIT False"
  "numeral (Num.Bit0 x) XOR - numeral (Num.Bit1 y) = (numeral x XOR - numeral (y + Num.One)) BIT True"
  "numeral (Num.Bit1 x) XOR - numeral (Num.Bit0 y) = (numeral x XOR - numeral y) BIT True"
  "numeral (Num.Bit1 x) XOR - numeral (Num.Bit1 y) = (numeral x XOR - numeral (y + Num.One)) BIT False"
  "- numeral (Num.Bit0 x) XOR numeral (Num.Bit0 y) = (- numeral x XOR numeral y) BIT False"
  "- numeral (Num.Bit0 x) XOR numeral (Num.Bit1 y) = (- numeral x XOR numeral y) BIT True"
  "- numeral (Num.Bit1 x) XOR numeral (Num.Bit0 y) = (- numeral (x + Num.One) XOR numeral y) BIT True"
  "- numeral (Num.Bit1 x) XOR numeral (Num.Bit1 y) = (- numeral (x + Num.One) XOR numeral y) BIT False"
  "- numeral (Num.Bit0 x) XOR - numeral (Num.Bit0 y) = (- numeral x XOR - numeral y) BIT False"
  "- numeral (Num.Bit0 x) XOR - numeral (Num.Bit1 y) = (- numeral x XOR - numeral (y + Num.One)) BIT True"
  "- numeral (Num.Bit1 x) XOR - numeral (Num.Bit0 y) = (- numeral (x + Num.One) XOR - numeral y) BIT True"
  "- numeral (Num.Bit1 x) XOR - numeral (Num.Bit1 y) = (- numeral (x + Num.One) XOR - numeral (y + Num.One)) BIT False"
  "(1::int) XOR numeral (Num.Bit0 y) = numeral (Num.Bit1 y)"
  "(1::int) XOR numeral (Num.Bit1 y) = numeral (Num.Bit0 y)"
  "(1::int) XOR - numeral (Num.Bit0 y) = - numeral (Num.BitM y)"
  "(1::int) XOR - numeral (Num.Bit1 y) = - numeral (Num.Bit0 (y + Num.One))"
  "numeral (Num.Bit0 x) XOR (1::int) = numeral (Num.Bit1 x)"
  "numeral (Num.Bit1 x) XOR (1::int) = numeral (Num.Bit0 x)"
  "- numeral (Num.Bit0 x) XOR (1::int) = - numeral (Num.BitM x)"
  "- numeral (Num.Bit1 x) XOR (1::int) = - numeral (Num.Bit0 (x + Num.One))"
  by (rule bin_rl_eqI, simp, simp)+

subsubsection {* Interactions with arithmetic *}

lemma plus_and_or [rule_format]:
  "ALL y::int. (x AND y) + (x OR y) = x + y"
  apply (induct x rule: bin_induct)
    apply clarsimp
   apply clarsimp
  apply clarsimp
  apply (case_tac y rule: bin_exhaust)
  apply clarsimp
  apply (unfold Bit_def)
  apply clarsimp
  apply (erule_tac x = "x" in allE)
  apply simp
  done

lemma le_int_or:
  "bin_sign (y::int) = 0 ==> x <= x OR y"
  apply (induct y arbitrary: x rule: bin_induct)
    apply clarsimp
   apply clarsimp
  apply (case_tac x rule: bin_exhaust)
  apply (case_tac b)
   apply (case_tac [!] bit)
     apply (auto simp: le_Bits)
  done

lemmas int_and_le =
  xtrans(3) [OF bbw_ao_absorbs (2) [THEN conjunct2, symmetric] le_int_or]

(* interaction between bit-wise and arithmetic *)
(* good example of bin_induction *)
lemma bin_add_not: "x + NOT x = (-1::int)"
  apply (induct x rule: bin_induct)
    apply clarsimp
   apply clarsimp
  apply (case_tac bit, auto)
  done

subsubsection {* Truncating results of bit-wise operations *}

lemma bin_trunc_ao:
  "!!x y. (bintrunc n x) AND (bintrunc n y) = bintrunc n (x AND y)"
  "!!x y. (bintrunc n x) OR (bintrunc n y) = bintrunc n (x OR y)"
  by (auto simp add: bin_eq_iff bin_nth_ops nth_bintr)

lemma bin_trunc_xor:
  "!!x y. bintrunc n (bintrunc n x XOR bintrunc n y) =
          bintrunc n (x XOR y)"
  by (auto simp add: bin_eq_iff bin_nth_ops nth_bintr)

lemma bin_trunc_not:
  "!!x. bintrunc n (NOT (bintrunc n x)) = bintrunc n (NOT x)"
  by (auto simp add: bin_eq_iff bin_nth_ops nth_bintr)

(* want theorems of the form of bin_trunc_xor *)
lemma bintr_bintr_i:
  "x = bintrunc n y ==> bintrunc n x = bintrunc n y"
  by auto

lemmas bin_trunc_and = bin_trunc_ao(1) [THEN bintr_bintr_i]
lemmas bin_trunc_or = bin_trunc_ao(2) [THEN bintr_bintr_i]

subsection {* Setting and clearing bits *}

(** nth bit, set/clear **)

primrec
  bin_sc :: "nat => bool => int => int"
where
  Z: "bin_sc 0 b w = bin_rest w BIT b"
  | Suc: "bin_sc (Suc n) b w = bin_sc n b (bin_rest w) BIT bin_last w"

lemma bin_nth_sc [simp]:
  "bin_nth (bin_sc n b w) n \<longleftrightarrow> b"
  by (induct n arbitrary: w) auto

lemma bin_sc_sc_same [simp]:
  "bin_sc n c (bin_sc n b w) = bin_sc n c w"
  by (induct n arbitrary: w) auto

lemma bin_sc_sc_diff:
  "m ~= n ==>
    bin_sc m c (bin_sc n b w) = bin_sc n b (bin_sc m c w)"
  apply (induct n arbitrary: w m)
   apply (case_tac [!] m)
     apply auto
  done

lemma bin_nth_sc_gen:
  "bin_nth (bin_sc n b w) m = (if m = n then b else bin_nth w m)"
  by (induct n arbitrary: w m) (case_tac [!] m, auto)

lemma bin_sc_nth [simp]:
  "(bin_sc n (bin_nth w n) w) = w"
  by (induct n arbitrary: w) auto

lemma bin_sign_sc [simp]:
  "bin_sign (bin_sc n b w) = bin_sign w"
  by (induct n arbitrary: w) auto

lemma bin_sc_bintr [simp]:
  "bintrunc m (bin_sc n x (bintrunc m (w))) = bintrunc m (bin_sc n x w)"
  apply (induct n arbitrary: w m)
   apply (case_tac [!] w rule: bin_exhaust)
   apply (case_tac [!] m, auto)
  done

lemma bin_clr_le:
  "bin_sc n False w <= w"
  apply (induct n arbitrary: w)
   apply (case_tac [!] w rule: bin_exhaust)
   apply (auto simp: le_Bits)
  done

lemma bin_set_ge:
  "bin_sc n True w >= w"
  apply (induct n arbitrary: w)
   apply (case_tac [!] w rule: bin_exhaust)
   apply (auto simp: le_Bits)
  done

lemma bintr_bin_clr_le:
  "bintrunc n (bin_sc m False w) <= bintrunc n w"
  apply (induct n arbitrary: w m)
   apply simp
  apply (case_tac w rule: bin_exhaust)
  apply (case_tac m)
   apply (auto simp: le_Bits)
  done

lemma bintr_bin_set_ge:
  "bintrunc n (bin_sc m True w) >= bintrunc n w"
  apply (induct n arbitrary: w m)
   apply simp
  apply (case_tac w rule: bin_exhaust)
  apply (case_tac m)
   apply (auto simp: le_Bits)
  done

lemma bin_sc_FP [simp]: "bin_sc n False 0 = 0"
  by (induct n) auto

lemma bin_sc_TM [simp]: "bin_sc n True (- 1) = - 1"
  by (induct n) auto

lemmas bin_sc_simps = bin_sc.Z bin_sc.Suc bin_sc_TM bin_sc_FP

lemma bin_sc_minus:
  "0 < n ==> bin_sc (Suc (n - 1)) b w = bin_sc n b w"
  by auto

lemmas bin_sc_Suc_minus =
  trans [OF bin_sc_minus [symmetric] bin_sc.Suc]

lemma bin_sc_numeral [simp]:
  "bin_sc (numeral k) b w =
    bin_sc (pred_numeral k) b (bin_rest w) BIT bin_last w"
  by (simp add: numeral_eq_Suc)

subsection {* Splitting and concatenation *}

definition bin_rcat :: "nat \<Rightarrow> int list \<Rightarrow> int"
where
  "bin_rcat n = foldl (\<lambda>u v. bin_cat u n v) 0"

fun bin_rsplit_aux :: "nat \<Rightarrow> nat \<Rightarrow> int \<Rightarrow> int list \<Rightarrow> int list"
where
  "bin_rsplit_aux n m c bs =
    (if m = 0 | n = 0 then bs else
      let (a, b) = bin_split n c
      in bin_rsplit_aux n (m - n) a (b # bs))"

definition bin_rsplit :: "nat \<Rightarrow> nat \<times> int \<Rightarrow> int list"
where
  "bin_rsplit n w = bin_rsplit_aux n (fst w) (snd w) []"

fun bin_rsplitl_aux :: "nat \<Rightarrow> nat \<Rightarrow> int \<Rightarrow> int list \<Rightarrow> int list"
where
  "bin_rsplitl_aux n m c bs =
    (if m = 0 | n = 0 then bs else
      let (a, b) = bin_split (min m n) c
      in bin_rsplitl_aux n (m - n) a (b # bs))"

definition bin_rsplitl :: "nat \<Rightarrow> nat \<times> int \<Rightarrow> int list"
where
  "bin_rsplitl n w = bin_rsplitl_aux n (fst w) (snd w) []"

declare bin_rsplit_aux.simps [simp del]
declare bin_rsplitl_aux.simps [simp del]

lemma bin_sign_cat:
  "bin_sign (bin_cat x n y) = bin_sign x"
  by (induct n arbitrary: y) auto

lemma bin_cat_Suc_Bit:
  "bin_cat w (Suc n) (v BIT b) = bin_cat w n v BIT b"
  by auto

lemma bin_nth_cat:
  "bin_nth (bin_cat x k y) n =
    (if n < k then bin_nth y n else bin_nth x (n - k))"
  apply (induct k arbitrary: n y)
   apply clarsimp
  apply (case_tac n, auto)
  done

lemma bin_nth_split:
  "bin_split n c = (a, b) ==>
    (ALL k. bin_nth a k = bin_nth c (n + k)) &
    (ALL k. bin_nth b k = (k < n & bin_nth c k))"
  apply (induct n arbitrary: b c)
   apply clarsimp
  apply (clarsimp simp: Let_def split: prod.split_asm)
  apply (case_tac k)
  apply auto
  done

lemma bin_cat_assoc:
  "bin_cat (bin_cat x m y) n z = bin_cat x (m + n) (bin_cat y n z)"
  by (induct n arbitrary: z) auto

lemma bin_cat_assoc_sym:
  "bin_cat x m (bin_cat y n z) = bin_cat (bin_cat x (m - n) y) (min m n) z"
  apply (induct n arbitrary: z m, clarsimp)
  apply (case_tac m, auto)
  done

lemma bin_cat_zero [simp]: "bin_cat 0 n w = bintrunc n w"
  by (induct n arbitrary: w) auto

lemma bintr_cat1:
  "bintrunc (k + n) (bin_cat a n b) = bin_cat (bintrunc k a) n b"
  by (induct n arbitrary: b) auto

lemma bintr_cat: "bintrunc m (bin_cat a n b) =
    bin_cat (bintrunc (m - n) a) n (bintrunc (min m n) b)"
  by (rule bin_eqI) (auto simp: bin_nth_cat nth_bintr)

lemma bintr_cat_same [simp]:
  "bintrunc n (bin_cat a n b) = bintrunc n b"
  by (auto simp add : bintr_cat)

lemma cat_bintr [simp]:
  "bin_cat a n (bintrunc n b) = bin_cat a n b"
  by (induct n arbitrary: b) auto

lemma split_bintrunc:
  "bin_split n c = (a, b) ==> b = bintrunc n c"
  by (induct n arbitrary: b c) (auto simp: Let_def split: prod.split_asm)

lemma bin_cat_split:
  "bin_split n w = (u, v) ==> w = bin_cat u n v"
  by (induct n arbitrary: v w) (auto simp: Let_def split: prod.split_asm)

lemma bin_split_cat:
  "bin_split n (bin_cat v n w) = (v, bintrunc n w)"
  by (induct n arbitrary: w) auto

lemma bin_split_zero [simp]: "bin_split n 0 = (0, 0)"
  by (induct n) auto

lemma bin_split_minus1 [simp]:
  "bin_split n (- 1) = (- 1, bintrunc n (- 1))"
  by (induct n) auto

lemma bin_split_trunc:
  "bin_split (min m n) c = (a, b) ==>
    bin_split n (bintrunc m c) = (bintrunc (m - n) a, b)"
  apply (induct n arbitrary: m b c, clarsimp)
  apply (simp add: bin_rest_trunc Let_def split: prod.split_asm)
  apply (case_tac m)
   apply (auto simp: Let_def split: prod.split_asm)
  done

lemma bin_split_trunc1:
  "bin_split n c = (a, b) ==>
    bin_split n (bintrunc m c) = (bintrunc (m - n) a, bintrunc m b)"
  apply (induct n arbitrary: m b c, clarsimp)
  apply (simp add: bin_rest_trunc Let_def split: prod.split_asm)
  apply (case_tac m)
   apply (auto simp: Let_def split: prod.split_asm)
  done

lemma bin_cat_num:
  "bin_cat a n b = a * 2 ^ n + bintrunc n b"
  apply (induct n arbitrary: b, clarsimp)
  apply (simp add: Bit_def)
  done

lemma bin_split_num:
  "bin_split n b = (b div 2 ^ n, b mod 2 ^ n)"
  apply (induct n arbitrary: b, simp)
  apply (simp add: bin_rest_def zdiv_zmult2_eq)
  apply (case_tac b rule: bin_exhaust)
  apply simp
  apply (simp add: Bit_def mod_mult_mult1 p1mod22k)
  done

subsection {* Miscellaneous lemmas *}

lemma nth_2p_bin:
  "bin_nth (2 ^ n) m = (m = n)"
  apply (induct n arbitrary: m)
   apply clarsimp
   apply safe
   apply (case_tac m)
    apply (auto simp: Bit_B0_2t [symmetric])
  done

(* for use when simplifying with bin_nth_Bit *)

lemma ex_eq_or:
  "(EX m. n = Suc m & (m = k | P m)) = (n = Suc k | (EX m. n = Suc m & P m))"
  by auto

lemma power_BIT: "2 ^ (Suc n) - 1 = (2 ^ n - 1) BIT True"
  unfolding Bit_B1
  by (induct n) simp_all

lemma mod_BIT:
  "bin BIT bit mod 2 ^ Suc n = (bin mod 2 ^ n) BIT bit"
proof -
  have "bin mod 2 ^ n < 2 ^ n" by simp
  then have "bin mod 2 ^ n \<le> 2 ^ n - 1" by simp
  then have "2 * (bin mod 2 ^ n) \<le> 2 * (2 ^ n - 1)"
    by (rule mult_left_mono) simp
  then have "2 * (bin mod 2 ^ n) + 1 < 2 * 2 ^ n" by simp
  then show ?thesis
    by (auto simp add: Bit_def mod_mult_mult1 mod_add_left_eq [of "2 * bin"]
      mod_pos_pos_trivial)
qed

lemma AND_mod:
  fixes x :: int
  shows "x AND 2 ^ n - 1 = x mod 2 ^ n"
proof (induct x arbitrary: n rule: bin_induct)
  case 1
  then show ?case
    by simp
next
  case 2
  then show ?case
    by (simp, simp add: m1mod2k)
next
  case (3 bin bit)
  show ?case
  proof (cases n)
    case 0
    then show ?thesis by simp
  next
    case (Suc m)
    with 3 show ?thesis
      by (simp only: power_BIT mod_BIT int_and_Bits) simp
  qed
qed

end


theory "Set-Cpo"
imports HOLCF
begin

default_sort type

instantiation set :: (type) below
begin
  definition below_set where "(\<sqsubseteq>) = (\<subseteq>)"
instance..
end

instance set :: (type) po
  by standard (auto simp add: below_set_def)

lemma is_lub_set:
  "S <<| \<Union>S"
  by(auto simp add: is_lub_def below_set_def is_ub_def)

lemma lub_set: "lub S = \<Union>S"
  by (metis is_lub_set lub_eqI)

instance set  :: (type) cpo
  by standard (rule exI, rule is_lub_set)

lemma minimal_set: "{} \<sqsubseteq> S"
  unfolding below_set_def by simp

instance set  :: (type) pcpo
  by standard (rule+, rule minimal_set)

lemma set_contI:
  assumes  "\<And> Y. chain Y \<Longrightarrow> f (\<Squnion> i. Y i) = \<Union> (f ` range Y)"
  shows "cont f"
proof(rule contI)
  fix Y :: "nat \<Rightarrow> 'a"
  assume "chain Y"
  hence "f (\<Squnion> i. Y i) = \<Union> (f ` range Y)" by (rule assms)
  also have "\<dots> = \<Union> (range (\<lambda>i. f (Y i)))" by simp
  finally
  show "range (\<lambda>i. f (Y i)) <<| f (\<Squnion> i. Y i)" using is_lub_set by metis
qed

lemma set_set_contI:
  assumes  "\<And> S. f (\<Union>S) = \<Union> (f ` S)"
  shows "cont f"
  by (metis set_contI assms is_lub_set  lub_eqI)

lemma adm_subseteq[simp]:
  assumes "cont f"
  shows "adm (\<lambda>a. f a \<subseteq> S)"
by (rule admI)(auto simp add: cont2contlubE[OF assms] lub_set)

lemma adm_Ball[simp]: "adm (\<lambda>S. \<forall>x\<in>S. P x)"
  by (auto intro!: admI  simp add: lub_set)

lemma finite_subset_chain:
  fixes Y :: "nat \<Rightarrow> 'a set"
  assumes "chain Y"
  assumes "S \<subseteq> \<Union>(Y ` UNIV)"
  assumes "finite S"
  shows "\<exists>i. S \<subseteq> Y i"
proof-
  from assms(2)
  have "\<forall>x \<in> S. \<exists> i. x \<in> Y i" by auto
  then obtain f where f: "\<forall> x\<in> S. x \<in> Y (f x)" by metis

  define i where "i = Max (f ` S)"
  from \<open>finite S\<close>
  have "finite (f ` S)" by simp
  hence "\<forall> x\<in>S. f x \<le> i" unfolding i_def by auto
  with chain_mono[OF \<open>chain Y\<close>]
  have "\<forall> x\<in>S. Y (f x) \<subseteq> Y i" by (auto simp add: below_set_def)
  with f
  have "S \<subseteq> Y i" by auto
  thus ?thesis..
qed

lemma diff_cont[THEN cont_compose, simp, cont2cont]:
  fixes S' :: "'a set"
  shows  "cont (\<lambda>S. S - S')"
by (rule set_set_contI) simp

end


theory OFEs
imports BasicTypes "HOL-Library.Finite_Map"
begin

section \<open> Ordered family of equivalences \<close>
text \<open> The definition of the class of OFEs and some instances. \<close>

section \<open> OFE \<close>
class ofe =
  fixes n_equiv :: "nat \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool"
    and ofe_eq :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (* Allow for custom equality *)
  assumes ofe_refl: "n_equiv n x x"
    and ofe_sym: "n_equiv n x y \<longleftrightarrow> n_equiv n y x"
    and ofe_trans: "\<lbrakk>n_equiv n x y; n_equiv n y z\<rbrakk> \<Longrightarrow> n_equiv n x z"
    and ofe_mono: "\<lbrakk>m\<le>n; n_equiv n x y\<rbrakk> \<Longrightarrow> n_equiv m x y"
    and ofe_limit: "(ofe_eq x y) \<longleftrightarrow> (\<forall>n. n_equiv n x y)"
    and ofe_eq_eq: "(x=y) \<Longrightarrow> ofe_eq x y"
begin
lemma  ofe_eq_limit: "(x=y) \<Longrightarrow> (\<forall>n. n_equiv n x y)"
  using ofe_limit ofe_eq_eq by simp
end

class discrete = ofe + assumes d_equiv: "n_equiv n a b = (a=b)" and d_eq: "ofe_eq a b = (a=b)"

definition discrete_val :: "'a::ofe \<Rightarrow> bool" where
  "discrete_val v \<equiv> (\<forall>x n. n_equiv n v x \<longleftrightarrow> (v=x)) \<and> (\<forall>y. ofe_eq v y \<longleftrightarrow> (v=y))"

lemma discrete_discrete_val [simp]: "discrete_val (x::'a::discrete)"
  by (simp add: discrete_val_def d_equiv d_eq)

lemma ofe_down_contr: "n_equiv n x y \<longleftrightarrow> (\<forall>m\<le>n. n_equiv m x y)"
  by (auto simp: ofe_trans ofe_sym intro: ofe_mono)

lemma ofe_trans_eqL: "n_equiv n x y \<Longrightarrow> n_equiv n x z \<longleftrightarrow> n_equiv n y z"
  using ofe_sym ofe_trans by blast

lemma ofe_trans_eqR: "n_equiv n x y \<Longrightarrow> n_equiv n z x \<longleftrightarrow> n_equiv n z y"
  using ofe_sym ofe_trans by blast

lemma ofe_trans': "\<lbrakk>ofe_eq x y; ofe_eq y z\<rbrakk> \<Longrightarrow> ofe_eq x z"
  by (auto simp: ofe_limit intro: ofe_trans)

lemma ofe_eq_equiv: "ofe_eq x y \<Longrightarrow> n_equiv n x y" by (simp add: ofe_limit)

subsection \<open> Basic OFE instances \<close>
subsubsection \<open>unit OFE\<close>
instantiation unit :: ofe begin
  definition n_equiv_unit :: "nat \<Rightarrow> unit \<Rightarrow> unit \<Rightarrow> bool" where
    "n_equiv_unit _ _ _ = True"
  fun ofe_eq_unit :: "unit \<Rightarrow> unit \<Rightarrow> bool" where "ofe_eq_unit _ _ = True"
instance by (standard, unfold n_equiv_unit_def) auto
end

instance unit :: discrete by standard (auto simp: n_equiv_unit_def)

subsubsection \<open>nat OFE\<close>
instantiation nat :: ofe begin
  definition n_equiv_nat :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bool" where [simp]: "n_equiv_nat \<equiv> \<lambda>_. (=)"
  definition ofe_eq_nat :: "nat \<Rightarrow> nat \<Rightarrow> bool" where [simp]: "ofe_eq_nat \<equiv> (=)"
instance by standard auto
end

instance nat :: discrete by standard (auto)

subsubsection \<open>bool OFE\<close>
instantiation bool :: ofe begin
  definition n_equiv_bool :: "nat \<Rightarrow> bool \<Rightarrow> bool \<Rightarrow> bool" where [simp]: "n_equiv_bool \<equiv> \<lambda>_. (=)"
  definition ofe_eq_bool :: "bool \<Rightarrow> bool \<Rightarrow> bool" where [simp]: "ofe_eq_bool \<equiv> (=)"
instance by standard auto
end

instance bool :: discrete by standard (auto)

subsubsection \<open>Set type OFE\<close>
instantiation set :: (type) ofe begin
definition n_equiv_set :: "nat \<Rightarrow> 'a set \<Rightarrow> 'a set \<Rightarrow> bool" where "n_equiv_set _ \<equiv> (=)"
definition ofe_eq_set :: "'a set \<Rightarrow> 'a set \<Rightarrow> bool" where "ofe_eq_set \<equiv> (=)"
instance by (standard) (auto simp: n_equiv_set_def ofe_eq_set_def)
end

instance set :: (type) discrete by standard (auto simp: n_equiv_set_def ofe_eq_set_def)

subsubsection \<open>Disjoint set OFE\<close>
instantiation dset :: (type) ofe begin
definition n_equiv_dset :: "nat \<Rightarrow> 'a dset \<Rightarrow> 'a dset \<Rightarrow> bool" where "n_equiv_dset \<equiv> \<lambda>_. (=)"
definition ofe_eq_dset :: "'a dset \<Rightarrow> 'a dset \<Rightarrow> bool" where "ofe_eq_dset \<equiv> (=)"
instance by standard (auto simp: n_equiv_dset_def ofe_eq_dset_def)
end

instance dset :: (type) discrete by standard (auto simp: n_equiv_dset_def ofe_eq_dset_def)

subsubsection \<open>option OFE\<close>
instantiation option :: (ofe) ofe begin
  definition n_equiv_option :: "nat \<Rightarrow> 'a option \<Rightarrow> 'a option \<Rightarrow> bool" where
  "n_equiv_option n x y \<equiv> (\<exists>x' y'. x=Some x'\<and>y=Some y'\<and> n_equiv n x' y') \<or> x=None\<and>y=None"
  definition ofe_eq_option where
    "ofe_eq_option x y \<equiv> (x=None\<and>y=None)\<or>(\<exists>x' y'. x=Some x'\<and>y=Some y'\<and>(ofe_eq x' y'))"
instance proof (standard)
  fix x y
  show "(ofe_eq (x::'a option) y) \<longleftrightarrow> (\<forall>n. n_equiv n x y)"
  by (auto simp: n_equiv_option_def ofe_refl ofe_eq_option_def) (metis ofe_limit option.sel)+
next
  fix x y n
  show "(n_equiv n (x::'a option) y) \<longleftrightarrow> (n_equiv n y x)"
    by (auto simp: n_equiv_option_def ofe_sym)
next
  fix m n x y
  show "\<lbrakk>m \<le> n; (n_equiv::nat\<Rightarrow>'a option\<Rightarrow>'a option\<Rightarrow>bool) n x y\<rbrakk> \<Longrightarrow> n_equiv m x y"
    by (auto simp: n_equiv_option_def ofe_mono)
qed (auto simp: n_equiv_option_def ofe_eq_option_def ofe_eq_eq ofe_refl intro: ofe_trans)
end

instance option :: (discrete) discrete
proof
fix a b :: "'a option" fix n
show "n_equiv n a b = (a=b)" by (cases a; cases b) (auto simp: n_equiv_option_def d_equiv)
next
fix a b :: "'a option"
show "ofe_eq a b = (a = b)" by (cases a; cases b) (auto simp: ofe_eq_option_def d_eq)
qed

subsubsection \<open>prod OFE\<close>
instantiation prod :: (ofe,ofe) ofe begin
  fun n_equiv_prod :: "nat \<Rightarrow> ('a\<times>'b) \<Rightarrow> ('a\<times>'b) \<Rightarrow> bool" where
    "n_equiv_prod n (x1,y1) (x2,y2) = (n_equiv n x1 x2 \<and> n_equiv n y1 y2)"
  fun ofe_eq_prod :: "'a\<times>'b \<Rightarrow> 'a\<times>'b \<Rightarrow> bool" where
    "ofe_eq_prod (a1,b1) (a2,b2) = (ofe_eq a1 a2 \<and> ofe_eq b1 b2)"
instance proof (standard)
  fix x n
  show "n_equiv n x (x::('a\<times>'b))"
    by (cases x) (auto simp: ofe_refl)
next
  fix m n x y
  assume "m\<le>(n::nat)"
  thus "(n_equiv:: nat\<Rightarrow>('a\<times>'b)\<Rightarrow>('a\<times>'b)\<Rightarrow>bool) n x y \<Longrightarrow> n_equiv m x y"
    by (cases x; cases y) (auto simp: ofe_mono Pair_inject)
next
  fix x y
  show "(ofe_eq (x::('a\<times>'b)) y) \<longleftrightarrow> (\<forall>n. n_equiv n x y)"
    by (cases x; cases y) (auto simp: ofe_limit)
qed (auto simp: ofe_sym ofe_eq_eq intro: ofe_refl ofe_trans)
end
instance prod :: (discrete,discrete) discrete by standard (auto simp: d_equiv d_eq)

subsubsection \<open>List type OFE\<close>
instantiation list :: (ofe) ofe begin
definition n_equiv_list :: "nat \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> bool" where [simp]: "n_equiv_list \<equiv> \<lambda>_. (=)"
definition ofe_eq_list :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool" where [simp]: "ofe_eq_list \<equiv> (=)"
instance by standard auto
end
instance list :: (discrete) discrete by standard auto

subsubsection \<open>Function type OFE\<close>
instantiation "fun" :: (type,ofe) ofe begin
definition n_equiv_fun :: "nat \<Rightarrow> ('a\<Rightarrow>'b) \<Rightarrow> ('a\<Rightarrow>'b) \<Rightarrow> bool" where
  "n_equiv_fun n m1 m2 \<equiv> \<forall>i. n_equiv n (m1 i) (m2 i)"
definition ofe_eq_fun :: "('a\<Rightarrow>'b) \<Rightarrow> ('a\<Rightarrow>'b) \<Rightarrow> bool" where
  "ofe_eq_fun m1 m2 \<equiv> \<forall>i. ofe_eq (m1 i) (m2 i)"
instance by (standard, unfold n_equiv_fun_def ofe_eq_fun_def)
  (auto simp: ofe_sym  ofe_limit intro: ofe_refl ofe_trans ofe_mono ofe_limit ofe_eq_eq)
end

instance "fun" :: (type,discrete) discrete
  by standard (auto simp: n_equiv_fun_def d_equiv ofe_eq_fun_def d_eq)

subsubsection \<open>Finite set OFE\<close>
instantiation fset :: (type) ofe begin
definition n_equiv_fset :: "nat \<Rightarrow> 'a fset \<Rightarrow> 'a fset \<Rightarrow> bool" where [simp]: "n_equiv_fset _ \<equiv> (=)"
definition ofe_eq_fset :: "'a fset \<Rightarrow> 'a fset \<Rightarrow> bool" where [simp]: "ofe_eq_fset \<equiv> (=)"
instance by (standard) auto
end

instance fset :: (type) discrete by standard auto

subsubsection \<open>Disjoint finite set OFE\<close>
instantiation dfset :: (type) ofe begin
definition n_equiv_dfset :: "nat \<Rightarrow> 'a dfset \<Rightarrow> 'a dfset \<Rightarrow> bool" where "n_equiv_dfset \<equiv> \<lambda>_. (=)"
definition ofe_eq_dfset :: "'a dfset \<Rightarrow> 'a dfset \<Rightarrow> bool" where "ofe_eq_dfset \<equiv> (=)"
instance by standard (auto simp: n_equiv_dfset_def ofe_eq_dfset_def)
end

instance dfset :: (type) discrete by standard (auto simp: n_equiv_dfset_def ofe_eq_dfset_def)

subsubsection \<open>Finite map OFE\<close>
instantiation fmap :: (type,ofe) ofe begin
context includes fmap.lifting begin
lift_definition n_equiv_fmap :: "nat \<Rightarrow> ('a, 'b) fmap \<Rightarrow> ('a, 'b) fmap \<Rightarrow> bool" is
  "n_equiv::nat\<Rightarrow>('a\<rightharpoonup>'b) \<Rightarrow> ('a\<rightharpoonup>'b) \<Rightarrow> bool" .
lift_definition ofe_eq_fmap :: "('a, 'b) fmap \<Rightarrow> ('a, 'b) fmap \<Rightarrow> bool" is
  "ofe_eq::('a\<rightharpoonup>'b) \<Rightarrow> ('a\<rightharpoonup>'b) \<Rightarrow> bool" .
instance by (standard; transfer')
  (auto simp: ofe_refl ofe_sym ofe_trans ofe_eq_eq ofe_limit intro: ofe_mono)
end
end

instance fmap :: (type,discrete) discrete by standard
  (auto simp: d_equiv d_eq n_equiv_fmap.rep_eq ofe_eq_fmap.rep_eq fmlookup_inject)

subsubsection \<open>Extended sum type\<close>
instantiation sum_ext :: (ofe,ofe) ofe begin
  fun ofe_eq_sum_ext :: "'a+\<^sub>e'b \<Rightarrow> 'a+\<^sub>e'b \<Rightarrow> bool" where
    "ofe_eq_sum_ext (Inl a) (Inl b) = ofe_eq a b"
  | "ofe_eq_sum_ext (Inr a) (Inr b) = ofe_eq a b"
  | "ofe_eq_sum_ext sum_ext.Inv sum_ext.Inv = True"
  | "ofe_eq_sum_ext _ _ = False"
  fun n_equiv_sum_ext :: "nat \<Rightarrow> 'a+\<^sub>e'b \<Rightarrow> 'a+\<^sub>e'b \<Rightarrow> bool" where
    "n_equiv_sum_ext n (Inl x) (Inl y) = n_equiv n x y"
  | "n_equiv_sum_ext n (Inr x) (Inr y) =  n_equiv n x y"
  | "n_equiv_sum_ext _ sum_ext.Inv sum_ext.Inv = True"
  | "n_equiv_sum_ext _ _ _ = False"
instance proof
  fix n x
  show "n_equiv n x (x::'a+\<^sub>e'b)" by (cases x) (auto simp: ofe_refl)
next
  fix n x y
  show "n_equiv n x y = n_equiv n y (x::'a+\<^sub>e'b)"
    by (cases x y rule: sum_ex2) (auto simp: ofe_sym)
next
  fix n x y z
  show "n_equiv n x y \<Longrightarrow> n_equiv n y z \<Longrightarrow> n_equiv n x (z::'a+\<^sub>e'b)"
    by (cases x y z rule: sum_ex3) (auto intro: ofe_trans)
next
  fix m n x y
  show "m \<le> n \<Longrightarrow> n_equiv n x y \<Longrightarrow> n_equiv m x (y::'a+\<^sub>e'b)"
  by (cases x y rule: sum_ex2) (auto intro: ofe_mono)
next
  fix x y :: "'a+\<^sub>e'b"
  show "ofe_eq x y \<longleftrightarrow> (\<forall>n. n_equiv n x y)"
  apply (cases x; cases y)
  apply simp_all
  using ofe_limit by blast+
next
  fix x y :: "'a+\<^sub>e'b"
  show "(x=y) \<Longrightarrow> ofe_eq x y" by (cases x y rule: sum_ex2) (auto intro: ofe_eq_eq)
qed
end

instance sum_ext :: (discrete,discrete) discrete
proof
fix a b :: "'a+\<^sub>e'b" fix n
show "n_equiv n a b = (a = b)" by (cases a b rule: sum_ex2) (auto simp: d_equiv)
next
fix a b :: "'a+\<^sub>e'b"
show "ofe_eq a b = (a = b)" by (cases a b rule: sum_ex2) (auto simp: d_eq)
qed

subsection \<open> Advanced OFE instances\<close>

subsubsection \<open> Step indexed proposition OFE\<close>
instantiation sprop :: ofe begin
  definition n_equiv_sprop :: "nat \<Rightarrow> sprop \<Rightarrow> sprop \<Rightarrow> bool" where
    "n_equiv_sprop n x y \<equiv> \<forall>m\<le>n. Rep_sprop x m \<longleftrightarrow> Rep_sprop y m"
  definition ofe_eq_sprop :: "sprop \<Rightarrow> sprop \<Rightarrow> bool" where
    "ofe_eq_sprop x y \<equiv> \<forall>n. (Rep_sprop x n) \<longleftrightarrow> (Rep_sprop y n)"
instance by (standard, unfold n_equiv_sprop_def ofe_eq_sprop_def) auto
end

subsubsection \<open>later type OFE\<close>
instantiation later :: (ofe) ofe begin
  definition n_equiv_later :: "nat \<Rightarrow> 'a later \<Rightarrow> 'a later \<Rightarrow> bool" where
    "n_equiv_later n x y = (n=0 \<or> n_equiv (n-1) (later_car x) (later_car y))"
  fun ofe_eq_later :: "'a later \<Rightarrow> 'a later \<Rightarrow> bool" where
    "ofe_eq_later (Next a) (Next b) = ofe_eq a b"
instance proof (standard)
  fix x n
  show "n_equiv n (x::'a later) x"
    by (cases n; cases x) (auto simp: ofe_refl n_equiv_later_def)
next
  fix x y n
  show "(n_equiv n (x::'a later) y) \<longleftrightarrow> (n_equiv n y x)"
    by (cases n; cases x y rule: later2_ex) (auto simp: ofe_limit ofe_sym n_equiv_later_def)
next
  fix x y n z
  show "n_equiv n (x::'a later) y \<Longrightarrow> n_equiv n y z \<Longrightarrow> n_equiv n x z"
    by (cases n; cases x y z rule: later3_ex) (auto simp: n_equiv_later_def intro: ofe_trans)
next
  fix m n x y
  show "m \<le> n \<Longrightarrow> (n_equiv::nat\<Rightarrow>'a later\<Rightarrow>'a later\<Rightarrow>bool) n x y \<Longrightarrow> n_equiv m x y"
    by (cases m; cases n; cases x y rule: later2_ex) (auto simp: ofe_mono n_equiv_later_def)
next
  fix x y :: "'a later"
  show "(ofe_eq x y) \<longleftrightarrow> (\<forall>n. n_equiv n x y)"
  by (cases x y rule: later2_ex)
    (metis Zero_not_Suc diff_Suc_1 later.sel n_equiv_later_def ofe_eq_later.simps ofe_limit)
next
fix x y :: "'a later"
show "(x=y) \<Longrightarrow> ofe_eq x y" using OFEs.ofe_eq_later.elims(3) ofe_eq_eq by auto
qed
end

subsubsection \<open>Agreement camera combinator OFE\<close>
instantiation ag :: (ofe) ofe begin
lift_definition n_equiv_ag :: "nat \<Rightarrow> ('a::ofe) ag \<Rightarrow> 'a ag \<Rightarrow> bool" is
  "\<lambda>n a b. (\<forall>x\<in>a. \<exists>y\<in>b. n_equiv n x y) \<and> (\<forall>y\<in>b. \<exists>x\<in>a. n_equiv n x y)" .
definition ofe_eq_ag :: "('a::ofe) ag \<Rightarrow> 'a ag \<Rightarrow> bool" where
  "ofe_eq_ag a b \<equiv> \<forall>n. n_equiv n a b"
lemmas defs = n_equiv_ag.rep_eq ofe_eq_ag_def
instance by (standard) (auto 4 4 simp: defs ofe_sym intro: ofe_refl ofe_trans ofe_mono)
end

instance ag :: (discrete) discrete apply standard
  apply (simp_all add: n_equiv_ag.rep_eq d_equiv ofe_eq_ag_def)
  using Rep_ag_inject by blast+

lemma to_ag_n_equiv: "n_equiv n (to_ag a) (to_ag b) \<longleftrightarrow> n_equiv n a b"
  unfolding to_ag.rep_eq n_equiv_ag.rep_eq by simp

subsubsection \<open>Exclusive camera combinator OFE\<close>
instantiation ex :: (ofe) ofe begin
fun n_equiv_ex :: "nat \<Rightarrow> 'a::ofe ex \<Rightarrow> 'a ex \<Rightarrow> bool" where
  "n_equiv_ex n (Ex a) (Ex b) = n_equiv n a b"
| "n_equiv_ex _ ex.Inv ex.Inv = True"
| "n_equiv_ex _ _ _ = False"
fun ofe_eq_ex :: "'a ex \<Rightarrow> 'a ex \<Rightarrow> bool" where
  "ofe_eq_ex (Ex a) (Ex b) = ofe_eq a b"
| "ofe_eq_ex ex.Inv ex.Inv = True"
| "ofe_eq_ex _ _ = False"
instance proof
fix x n show "n_equiv n x (x::'a ex)" by (cases x) (auto intro: ofe_refl)
next fix n x y show "n_equiv n x y = n_equiv n y (x::'a ex)" by (cases x; cases y) (auto simp: ofe_sym)
next fix n x y z show "n_equiv n x y \<Longrightarrow> n_equiv n y z \<Longrightarrow> n_equiv n x (z::'a ex)"
  by (cases x; cases y; cases z) (auto intro: ofe_trans)
next fix m n x y show "m \<le> n \<Longrightarrow> n_equiv n x y \<Longrightarrow> n_equiv m x (y::'a ex)"
  by (cases x; cases y) (auto intro: ofe_mono)
next fix x y show "ofe_eq x y \<longleftrightarrow> (\<forall>n. n_equiv n x (y::'a ex))"
  apply (cases x; cases y) apply simp_all using ofe_limit by blast+
next fix x y show "x = y \<Longrightarrow> ofe_eq x (y::'a ex)" by (cases x; cases y) (auto intro: ofe_eq_eq)
qed
end

instance ex :: (discrete) discrete
proof
fix a b :: "'a ex" fix n
show "n_equiv n a b = (a = b)" by (cases a; cases b) (auto simp: d_equiv)
next
fix a b :: "'a ex"
show "ofe_eq a b = (a = b)" by (cases a; cases b) (auto simp: d_eq)
qed

subsubsection \<open>Authoritative camera combinator OFE\<close>

instantiation auth :: (ofe) ofe begin
fun n_equiv_auth :: "nat \<Rightarrow> 'a auth \<Rightarrow> 'a auth \<Rightarrow> bool" where
  "n_equiv_auth n (Auth a) (Auth b) = n_equiv n a b"
fun ofe_eq_auth :: "'a auth \<Rightarrow> 'a auth \<Rightarrow> bool" where
  "ofe_eq_auth (Auth a) (Auth b) = ofe_eq a b"
instance proof
fix n x show "n_equiv n x (x::'a auth)" by (cases x) (auto intro: ofe_refl) next
fix n x y show "n_equiv n x y \<longleftrightarrow> n_equiv n y (x::'a auth)"
  by (cases x; cases y) (auto simp: ofe_sym) next
fix n x y z show "n_equiv n x y \<Longrightarrow> n_equiv n y z \<Longrightarrow> n_equiv n x (z::'a auth)"
  by (cases x; cases y; cases z) (auto intro: ofe_trans) next
fix m n x y show "m \<le> n \<Longrightarrow> n_equiv n x y \<Longrightarrow> n_equiv m x (y::'a auth)"
  by (cases x; cases y) (auto intro: ofe_mono) next
fix x y show "ofe_eq x y \<longleftrightarrow> (\<forall>n. n_equiv n x (y::'a auth))" apply (cases x; cases y; auto)
  using ofe_limit by blast+ next
fix x y show " x = y \<Longrightarrow> ofe_eq x (y::'a auth)" by (cases x; cases y) (auto intro: ofe_eq_eq)
qed
end

instance auth :: (discrete) discrete
proof
fix a b :: "'a auth" fix n
show "n_equiv n a b = (a = b)" by (cases a; cases b) (auto simp: d_equiv)
next
fix a b :: "'a auth"
show "ofe_eq a b = (a = b)" by (cases a; cases b) (auto simp: d_eq)
qed
end


theory Binary_operations
 imports Bij_betw_simplicial_complex_bool_func
begin

section\<open>Binary operations over Boolean functions and simplicial complexes\<close>

text\<open>In this theory some results on binary operations over Boolean functions and
  their relationship to operations over the induced simplicial complexes are
  presented. We follow the presentation by Chastain and Scoville~\<^cite>\<open>\<open>Sect. 1.1\<close> in "CHSC"\<close>.\<close>

definition bool_fun_or :: "nat \<Rightarrow> (bool vec \<Rightarrow> bool) \<Rightarrow> (bool vec \<Rightarrow> bool) \<Rightarrow> (bool vec \<Rightarrow> bool)"
  where "(bool_fun_or n f g) \<equiv> (\<lambda>x. f x \<or> g x)"

definition bool_fun_and :: "nat \<Rightarrow> (bool vec \<Rightarrow> bool) \<Rightarrow> (bool vec \<Rightarrow> bool) \<Rightarrow> (bool vec \<Rightarrow> bool)"
  where "(bool_fun_and n f g) \<equiv> (\<lambda>x. f x \<and> g x)"

lemma eq_union_or:
  "simplicial_complex_induced_by_monotone_boolean_function n (bool_fun_or n f g)
  = simplicial_complex_induced_by_monotone_boolean_function n f
    \<union> simplicial_complex_induced_by_monotone_boolean_function n g"
  (is "?sc n (?bf_or n f g) = ?sc n f \<union> ?sc n g")
proof
  show "?sc n f \<union> ?sc n g \<subseteq> ?sc n (?bf_or n f g)"
  proof
    fix \<sigma> :: "nat set"
    assume "\<sigma> \<in> (?sc n f \<union> ?sc n g)"
    hence sigma: "\<sigma> \<in> ?sc n f \<or> \<sigma> \<in> ?sc n g" by auto
    have "f (simplicial_complex.bool_vec_from_simplice n \<sigma>)
           \<or> g (simplicial_complex.bool_vec_from_simplice n \<sigma>)"
    proof (cases "\<sigma> \<in> ?sc n f")
      case True
      from simplicial_complex.simplicial_complex_implies_true [OF True]
      show "f (simplicial_complex.bool_vec_from_simplice n \<sigma>)
           \<or> g (simplicial_complex.bool_vec_from_simplice n \<sigma>)" by fast
    next
      case False
      hence sigmain: "\<sigma> \<in> ?sc n g" using sigma by fast
      from simplicial_complex.simplicial_complex_implies_true [OF sigmain]
      show "f (simplicial_complex.bool_vec_from_simplice n \<sigma>)
           \<or> g (simplicial_complex.bool_vec_from_simplice n \<sigma>)" by fast
    qed
    thus "\<sigma> \<in> ?sc n (?bf_or n f g)"
      using simplicial_complex_induced_by_monotone_boolean_function_def
      using bool_fun_or_def sigma by auto
  qed
next
  show "?sc n (?bf_or n f g) \<subseteq> ?sc n f \<union> ?sc n g"
  proof
    fix \<sigma>::"nat set"
    assume sigma: "\<sigma> \<in> ?sc n (?bf_or n f g)"
    hence "bool_fun_or n f g (simplicial_complex.bool_vec_from_simplice n \<sigma>)"
      unfolding simplicial_complex.bool_vec_from_simplice_def
      unfolding simplicial_complex_induced_by_monotone_boolean_function_def
      unfolding ceros_of_boolean_input_def
      by auto (smt (verit) dim_vec eq_vecI index_vec)+
    hence "(f (simplicial_complex.bool_vec_from_simplice n \<sigma>))
            \<or> (g (simplicial_complex.bool_vec_from_simplice n \<sigma>))"
      unfolding bool_fun_or_def
      by auto
    hence "\<sigma> \<in> ?sc n f \<or> \<sigma> \<in> ?sc n g"
      by (smt (z3) sigma bool_fun_or_def mem_Collect_eq
            simplicial_complex_induced_by_monotone_boolean_function_def)
    thus "\<sigma> \<in> simplicial_complex_induced_by_monotone_boolean_function n f
          \<union> simplicial_complex_induced_by_monotone_boolean_function n g"
      by auto
  qed
qed

lemma eq_inter_and:
  "simplicial_complex_induced_by_monotone_boolean_function n (bool_fun_and n f g)
  = simplicial_complex_induced_by_monotone_boolean_function n f
    \<inter> simplicial_complex_induced_by_monotone_boolean_function n g"
  (is "?sc n (?bf_and n f g) = ?sc n f \<inter> ?sc n g")
proof
  show "?sc n f \<inter> ?sc n g \<subseteq> ?sc n (?bf_and n f g)"
  proof
    fix \<sigma> :: "nat set"
    assume "\<sigma> \<in> (?sc n f \<inter> ?sc n g)"
    hence sigma: "\<sigma> \<in> ?sc n f \<and> \<sigma> \<in> ?sc n g" by auto
    have "f (simplicial_complex.bool_vec_from_simplice n \<sigma>)
           \<and> g (simplicial_complex.bool_vec_from_simplice n \<sigma>)"
    proof -
      from sigma have sigmaf: "\<sigma> \<in> ?sc n f" and sigmag: "\<sigma> \<in> ?sc n g"
        by auto
      have "f (simplicial_complex.bool_vec_from_simplice n \<sigma>)"
        using simplicial_complex.simplicial_complex_implies_true [OF sigmaf] .
      moreover have "g (simplicial_complex.bool_vec_from_simplice n \<sigma>)"
        using simplicial_complex.simplicial_complex_implies_true [OF sigmag] .
      ultimately show ?thesis by fast
    qed
    thus "\<sigma> \<in> ?sc n (?bf_and n f g)"
      unfolding simplicial_complex_induced_by_monotone_boolean_function_def
      unfolding bool_fun_and_def
      using sigma apply auto
      by (smt (z3) Collect_cong ceros_of_boolean_input_def dim_vec index_vec mem_Collect_eq
          simplicial_complex.bool_vec_from_simplice_def
          simplicial_complex_induced_by_monotone_boolean_function_def)
  qed
next
  show "?sc n (?bf_and n f g) \<subseteq> ?sc n f \<inter> ?sc n g"
  proof
    fix \<sigma> :: "nat set"
    assume sigma: "\<sigma> \<in> ?sc n (?bf_and n f g)"
    hence "bool_fun_and n f g (simplicial_complex.bool_vec_from_simplice n \<sigma>)"
      unfolding simplicial_complex.bool_vec_from_simplice_def
      unfolding simplicial_complex_induced_by_monotone_boolean_function_def
      unfolding ceros_of_boolean_input_def
      by auto (smt (verit) dim_vec eq_vecI index_vec)+
    hence "(f (simplicial_complex.bool_vec_from_simplice n \<sigma>))
          \<and> (g (simplicial_complex.bool_vec_from_simplice n \<sigma>))"
      unfolding bool_fun_and_def
      by auto
    hence "\<sigma> \<in> ?sc n f \<and> \<sigma> \<in> ?sc n g"
      using bool_fun_and_def sigma simplicial_complex_induced_by_monotone_boolean_function_def by auto
    thus "\<sigma> \<in> simplicial_complex_induced_by_monotone_boolean_function n f
          \<inter> simplicial_complex_induced_by_monotone_boolean_function n g"
      by auto
  qed
qed

definition bool_fun_ast :: "(nat \<times> nat) \<Rightarrow> (bool vec \<Rightarrow> bool) \<times> (bool vec \<Rightarrow> bool)
    \<Rightarrow> (bool vec \<times> bool vec \<Rightarrow> bool)"
  where "(bool_fun_ast n f) \<equiv> (\<lambda> (x,y). (fst f x) \<and> (snd f y))"

definition
  simplicial_complex_induced_by_monotone_boolean_function_ast
    :: "(nat \<times> nat) \<Rightarrow> ((bool vec \<times> bool vec \<Rightarrow> bool)) \<Rightarrow> (nat set * nat set) set"
  where "simplicial_complex_induced_by_monotone_boolean_function_ast n f =
        {z. \<exists>x y. dim_vec x = fst n \<and> dim_vec y = snd n \<and> f (x, y)
          \<and> ((ceros_of_boolean_input x), (ceros_of_boolean_input y)) = z}"

lemma fst_es_simplice:
  "a \<in> simplicial_complex_induced_by_monotone_boolean_function_ast n f
    \<Longrightarrow> (\<exists>x y. f (x, y) \<and> (ceros_of_boolean_input x) = fst(a))"
  by (smt (verit) fst_conv mem_Collect_eq
        simplicial_complex_induced_by_monotone_boolean_function_ast_def)

lemma snd_es_simplice:
  "a \<in> simplicial_complex_induced_by_monotone_boolean_function_ast n f
    \<Longrightarrow> (\<exists>x y. f (x, y) \<and> (ceros_of_boolean_input y) = snd(a))"
  by (smt (verit) snd_conv mem_Collect_eq
      simplicial_complex_induced_by_monotone_boolean_function_ast_def)

definition set_ast :: "(nat set) set \<Rightarrow> (nat set) set \<Rightarrow> ((nat set*nat set) set)"
  where "set_ast A B \<equiv> {c. \<exists>a\<in>A. \<exists>b\<in>B. c = (a,b)}"

definition set_fst :: "(nat*nat) set \<Rightarrow> nat set"
  where "set_fst AB = {a. \<exists>ab\<in>AB. a = fst ab}"

lemma set_fst_simp [simp]:
  assumes "y \<noteq> {}"
  shows "set_fst (x \<times> y) = x"
proof
  show "set_fst (x \<times> y) \<subseteq> x"
    by (smt (verit) SigmaE mem_Collect_eq prod.sel(1) set_fst_def subsetI)
  show "x \<subseteq> set_fst (x \<times> y)"
  proof
    fix a::"nat"
    assume "a \<in> x"
    then obtain b where "b \<in> y" and "(a,b) \<in> (x\<times>y)"
      using assms by blast
    then show "a \<in> set_fst (x \<times> y)"
      using set_fst_def by fastforce
  qed
qed

definition set_snd :: "(nat*nat) set \<Rightarrow> nat set"
  where "set_snd AB = {b. \<exists>ab\<in>AB. b = snd(ab)}"

lemma
  simplicial_complex_ast_implies_fst_true:
  assumes "\<gamma> \<in> simplicial_complex_induced_by_monotone_boolean_function_ast nn
     (bool_fun_ast nn f)"
  shows "fst f (simplicial_complex.bool_vec_from_simplice (fst nn) (fst \<gamma>))"
  using assms
  unfolding simplicial_complex.bool_vec_from_simplice_def
  unfolding simplicial_complex_induced_by_monotone_boolean_function_ast_def
  unfolding bool_fun_ast_def
  unfolding ceros_of_boolean_input_def
  apply auto
  by (smt (verit, ccfv_threshold) bool_fun_ast_def case_prod_conv dim_vec index_vec vec_eq_iff)

lemma
  simplicial_complex_ast_implies_snd_true:
  assumes "\<gamma> \<in> simplicial_complex_induced_by_monotone_boolean_function_ast nn
     (bool_fun_ast nn f)"
  shows "snd f (simplicial_complex.bool_vec_from_simplice (snd nn) (snd \<gamma>))"
  using assms
  unfolding simplicial_complex.bool_vec_from_simplice_def
  unfolding simplicial_complex_induced_by_monotone_boolean_function_ast_def
  unfolding bool_fun_ast_def
  unfolding ceros_of_boolean_input_def
  by auto (smt (verit, ccfv_threshold) bool_fun_ast_def
        case_prod_conv dim_vec index_vec vec_eq_iff)

lemma eq_ast:
"simplicial_complex_induced_by_monotone_boolean_function_ast (n, m) (bool_fun_ast (n, m) f)
= set_ast (simplicial_complex_induced_by_monotone_boolean_function n (fst f))
          (simplicial_complex_induced_by_monotone_boolean_function m (snd f))"
proof
  show "set_ast (simplicial_complex_induced_by_monotone_boolean_function n (fst f))
     (simplicial_complex_induced_by_monotone_boolean_function m (snd f))
    \<subseteq> simplicial_complex_induced_by_monotone_boolean_function_ast (n, m)
        (bool_fun_ast (n, m) f)"
  proof
    fix \<gamma>::"nat set*nat set"
    assume pert: "\<gamma> \<in> set_ast (simplicial_complex_induced_by_monotone_boolean_function n (fst f))
     (simplicial_complex_induced_by_monotone_boolean_function m (snd f))"
    hence f: "(fst \<gamma>) \<in> simplicial_complex_induced_by_monotone_boolean_function n (fst f)"
      unfolding set_ast_def
      by auto
    have sigma: "fst f (simplicial_complex.bool_vec_from_simplice n (fst \<gamma>))"
      using simplicial_complex.simplicial_complex_implies_true [OF f] .
    from pert have g: "(snd \<gamma>) \<in> simplicial_complex_induced_by_monotone_boolean_function m (snd f)"
      unfolding set_ast_def by auto
    have tau: "(snd f) (simplicial_complex.bool_vec_from_simplice m (snd \<gamma>))"
      using simplicial_complex.simplicial_complex_implies_true [OF g] .
    from sigma and tau have sigtau: "bool_fun_ast (n, m) f
        ((simplicial_complex.bool_vec_from_simplice n (fst \<gamma>)),
         (simplicial_complex.bool_vec_from_simplice m (snd \<gamma>)))"
      unfolding bool_fun_ast_def
      by auto
    from sigtau
    show "\<gamma> \<in> simplicial_complex_induced_by_monotone_boolean_function_ast (n, m)
              (bool_fun_ast (n, m) f)"
      unfolding simplicial_complex_induced_by_monotone_boolean_function_ast_def
      unfolding bool_fun_ast_def
      using sigma apply auto
      using f g simplicial_complex_induced_by_monotone_boolean_function_def by fastforce
  qed
next
  show "simplicial_complex_induced_by_monotone_boolean_function_ast (n, m)
     (bool_fun_ast (n, m) f)
    \<subseteq> set_ast (simplicial_complex_induced_by_monotone_boolean_function n (fst f))
        (simplicial_complex_induced_by_monotone_boolean_function m (snd f))"
    proof
    fix \<gamma> :: "nat set*nat set"
    assume pert: "\<gamma> \<in> simplicial_complex_induced_by_monotone_boolean_function_ast (n, m)
     (bool_fun_ast (n, m) f)"
    have sigma: "(fst \<gamma>) \<in> simplicial_complex_induced_by_monotone_boolean_function n (fst f)"
      unfolding bool_fun_ast_def
      unfolding simplicial_complex_induced_by_monotone_boolean_function_def
      unfolding simplicial_complex_induced_by_monotone_boolean_function_ast_def
      apply auto
      apply (rule exI [of _ "simplicial_complex.bool_vec_from_simplice n (fst \<gamma>)"], safe)
      using simplicial_complex.bool_vec_from_simplice_def apply auto[1]
        apply (metis fst_conv pert simplicial_complex_ast_implies_fst_true)
      using ceros_of_boolean_input_def simplicial_complex.bool_vec_from_simplice_def
        apply fastforce
      using ceros_of_boolean_input_def pert
          simplicial_complex.bool_vec_from_simplice_def
          simplicial_complex_induced_by_monotone_boolean_function_ast_def by force
   have tau: "(snd \<gamma>) \<in> simplicial_complex_induced_by_monotone_boolean_function m (snd f)"
      unfolding bool_fun_ast_def
      unfolding simplicial_complex_induced_by_monotone_boolean_function_def
      unfolding simplicial_complex_induced_by_monotone_boolean_function_ast_def
      apply auto
      apply (rule exI [of _ "simplicial_complex.bool_vec_from_simplice m (snd \<gamma>)"], safe)
      using simplicial_complex.bool_vec_from_simplice_def apply auto[1]
        apply (metis snd_conv pert simplicial_complex_ast_implies_snd_true)
      using ceros_of_boolean_input_def simplicial_complex.bool_vec_from_simplice_def
       apply fastforce
      using ceros_of_boolean_input_def pert
        simplicial_complex.bool_vec_from_simplice_def
        simplicial_complex_induced_by_monotone_boolean_function_ast_def by force
    from sigma and tau
    show "\<gamma> \<in> set_ast
        (simplicial_complex_induced_by_monotone_boolean_function n (fst f))
        (simplicial_complex_induced_by_monotone_boolean_function m (snd f))"
      using set_ast_def
      by force
  qed
qed

end


(*  Title:      HOL/Statespace/DistinctTreeProver.thy
    Author:     Norbert Schirmer, TU Muenchen
*)

section \<open>Distinctness of Names in a Binary Tree \label{sec:DistinctTreeProver}\<close>

theory DistinctTreeProver
imports Main
begin

text \<open>A state space manages a set of (abstract) names and assumes
that the names are distinct. The names are stored as parameters of a
locale and distinctness as an assumption. The most common request is
to proof distinctness of two given names. We maintain the names in a
balanced binary tree and formulate a predicate that all nodes in the
tree have distinct names. This setup leads to logarithmic certificates.
\<close>

subsection \<open>The Binary Tree\<close>

datatype 'a tree = Node "'a tree" 'a bool "'a tree" | Tip

text \<open>The boolean flag in the node marks the content of the node as
deleted, without having to build a new tree. We prefer the boolean
flag to an option type, so that the ML-layer can still use the node
content to facilitate binary search in the tree. The ML code keeps the
nodes sorted using the term order. We do not have to push ordering to
the HOL level.\<close>

subsection \<open>Distinctness of Nodes\<close>

primrec set_of :: "'a tree \<Rightarrow> 'a set"
where
  "set_of Tip = {}"
| "set_of (Node l x d r) = (if d then {} else {x}) \<union> set_of l \<union> set_of r"

primrec all_distinct :: "'a tree \<Rightarrow> bool"
where
  "all_distinct Tip = True"
| "all_distinct (Node l x d r) =
    ((d \<or> (x \<notin> set_of l \<and> x \<notin> set_of r)) \<and>
      set_of l \<inter> set_of r = {} \<and>
      all_distinct l \<and> all_distinct r)"

text \<open>Given a binary tree \<^term>\<open>t\<close> for which
\<^const>\<open>all_distinct\<close> holds, given two different nodes contained in the tree,
we want to write a ML function that generates a logarithmic
certificate that the content of the nodes is distinct. We use the
following lemmas to achieve this.\<close>

lemma all_distinct_left: "all_distinct (Node l x b r) \<Longrightarrow> all_distinct l"
  by simp

lemma all_distinct_right: "all_distinct (Node l x b r) \<Longrightarrow> all_distinct r"
  by simp

lemma distinct_left: "all_distinct (Node l x False r) \<Longrightarrow> y \<in> set_of l \<Longrightarrow> x \<noteq> y"
  by auto

lemma distinct_right: "all_distinct (Node l x False r) \<Longrightarrow> y \<in> set_of r \<Longrightarrow> x \<noteq> y"
  by auto

lemma distinct_left_right:
    "all_distinct (Node l z b r) \<Longrightarrow> x \<in> set_of l \<Longrightarrow> y \<in> set_of r \<Longrightarrow> x \<noteq> y"
  by auto

lemma in_set_root: "x \<in> set_of (Node l x False r)"
  by simp

lemma in_set_left: "y \<in> set_of l \<Longrightarrow>  y \<in> set_of (Node l x False r)"
  by simp

lemma in_set_right: "y \<in> set_of r \<Longrightarrow>  y \<in> set_of (Node l x False r)"
  by simp

lemma swap_neq: "x \<noteq> y \<Longrightarrow> y \<noteq> x"
  by blast

lemma neq_to_eq_False: "x\<noteq>y \<Longrightarrow> (x=y)\<equiv>False"
  by simp

subsection \<open>Containment of Trees\<close>

text \<open>When deriving a state space from other ones, we create a new
name tree which contains all the names of the parent state spaces and
assume the predicate \<^const>\<open>all_distinct\<close>. We then prove that the new
locale interprets all parent locales. Hence we have to show that the
new distinctness assumption on all names implies the distinctness
assumptions of the parent locales. This proof is implemented in ML. We
do this efficiently by defining a kind of containment check of trees
by ``subtraction''.  We subtract the parent tree from the new tree. If
this succeeds we know that \<^const>\<open>all_distinct\<close> of the new tree
implies \<^const>\<open>all_distinct\<close> of the parent tree.  The resulting
certificate is of the order \<^term>\<open>n * log(m)\<close> where \<^term>\<open>n\<close> is
the size of the (smaller) parent tree and \<^term>\<open>m\<close> the size of the
(bigger) new tree.\<close>

primrec delete :: "'a \<Rightarrow> 'a tree \<Rightarrow> 'a tree option"
where
  "delete x Tip = None"
| "delete x (Node l y d r) = (case delete x l of
                                Some l' \<Rightarrow>
                                 (case delete x r of
                                    Some r' \<Rightarrow> Some (Node l' y (d \<or> (x=y)) r')
                                  | None \<Rightarrow> Some (Node l' y (d \<or> (x=y)) r))
                               | None \<Rightarrow>
                                  (case delete x r of
                                     Some r' \<Rightarrow> Some (Node l y (d \<or> (x=y)) r')
                                   | None \<Rightarrow> if x=y \<and> \<not>d then Some (Node l y True r)
                                             else None))"

lemma delete_Some_set_of: "delete x t = Some t' \<Longrightarrow> set_of t' \<subseteq> set_of t"
proof (induct t arbitrary: t')
  case Tip thus ?case by simp
next
  case (Node l y d r)
  have del: "delete x (Node l y d r) = Some t'" by fact
  show ?case
  proof (cases "delete x l")
    case (Some l')
    note x_l_Some = this
    with Node.hyps
    have l'_l: "set_of l' \<subseteq> set_of l"
      by simp
    show ?thesis
    proof (cases "delete x r")
      case (Some r')
      with Node.hyps
      have "set_of r' \<subseteq> set_of r"
        by simp
      with l'_l Some x_l_Some del
      show ?thesis
        by (auto split: if_split_asm)
    next
      case None
      with l'_l Some x_l_Some del
      show ?thesis
        by (fastforce split: if_split_asm)
    qed
  next
    case None
    note x_l_None = this
    show ?thesis
    proof (cases "delete x r")
      case (Some r')
      with Node.hyps
      have "set_of r' \<subseteq> set_of r"
        by simp
      with Some x_l_None del
      show ?thesis
        by (fastforce split: if_split_asm)
    next
      case None
      with x_l_None del
      show ?thesis
        by (fastforce split: if_split_asm)
    qed
  qed
qed

lemma delete_Some_all_distinct:
  "delete x t = Some t' \<Longrightarrow> all_distinct t \<Longrightarrow> all_distinct t'"
proof (induct t arbitrary: t')
  case Tip thus ?case by simp
next
  case (Node l y d r)
  have del: "delete x (Node l y d r) = Some t'" by fact
  have "all_distinct (Node l y d r)" by fact
  then obtain
    dist_l: "all_distinct l" and
    dist_r: "all_distinct r" and
    d: "d \<or> (y \<notin> set_of l \<and> y \<notin> set_of r)" and
    dist_l_r: "set_of l \<inter> set_of r = {}"
    by auto
  show ?case
  proof (cases "delete x l")
    case (Some l')
    note x_l_Some = this
    from Node.hyps (1) [OF Some dist_l]
    have dist_l': "all_distinct l'"
      by simp
    from delete_Some_set_of [OF x_l_Some]
    have l'_l: "set_of l' \<subseteq> set_of l".
    show ?thesis
    proof (cases "delete x r")
      case (Some r')
      from Node.hyps (2) [OF Some dist_r]
      have dist_r': "all_distinct r'"
        by simp
      from delete_Some_set_of [OF Some]
      have "set_of r' \<subseteq> set_of r".

      with dist_l' dist_r' l'_l Some x_l_Some del d dist_l_r
      show ?thesis
        by fastforce
    next
      case None
      with l'_l dist_l'  x_l_Some del d dist_l_r dist_r
      show ?thesis
        by fastforce
    qed
  next
    case None
    note x_l_None = this
    show ?thesis
    proof (cases "delete x r")
      case (Some r')
      with Node.hyps (2) [OF Some dist_r]
      have dist_r': "all_distinct r'"
        by simp
      from delete_Some_set_of [OF Some]
      have "set_of r' \<subseteq> set_of r".
      with Some dist_r' x_l_None del dist_l d dist_l_r
      show ?thesis
        by fastforce
    next
      case None
      with x_l_None del dist_l dist_r d dist_l_r
      show ?thesis
        by (fastforce split: if_split_asm)
    qed
  qed
qed

lemma delete_None_set_of_conv: "delete x t = None = (x \<notin> set_of t)"
proof (induct t)
  case Tip thus ?case by simp
next
  case (Node l y d r)
  thus ?case
    by (auto split: option.splits)
qed

lemma delete_Some_x_set_of:
  "delete x t = Some t' \<Longrightarrow> x \<in> set_of t \<and> x \<notin> set_of t'"
proof (induct t arbitrary: t')
  case Tip thus ?case by simp
next
  case (Node l y d r)
  have del: "delete x (Node l y d r) = Some t'" by fact
  show ?case
  proof (cases "delete x l")
    case (Some l')
    note x_l_Some = this
    from Node.hyps (1) [OF Some]
    obtain x_l: "x \<in> set_of l" "x \<notin> set_of l'"
      by simp
    show ?thesis
    proof (cases "delete x r")
      case (Some r')
      from Node.hyps (2) [OF Some]
      obtain x_r: "x \<in> set_of r" "x \<notin> set_of r'"
        by simp
      from x_r x_l Some x_l_Some del
      show ?thesis
        by (clarsimp split: if_split_asm)
    next
      case None
      then have "x \<notin> set_of r"
        by (simp add: delete_None_set_of_conv)
      with x_l None x_l_Some del
      show ?thesis
        by (clarsimp split: if_split_asm)
    qed
  next
    case None
    note x_l_None = this
    then have x_notin_l: "x \<notin> set_of l"
      by (simp add: delete_None_set_of_conv)
    show ?thesis
    proof (cases "delete x r")
      case (Some r')
      from Node.hyps (2) [OF Some]
      obtain x_r: "x \<in> set_of r" "x \<notin> set_of r'"
        by simp
      from x_r x_notin_l Some x_l_None del
      show ?thesis
        by (clarsimp split: if_split_asm)
    next
      case None
      then have "x \<notin> set_of r"
        by (simp add: delete_None_set_of_conv)
      with None x_l_None x_notin_l del
      show ?thesis
        by (clarsimp split: if_split_asm)
    qed
  qed
qed

primrec subtract :: "'a tree \<Rightarrow> 'a tree \<Rightarrow> 'a tree option"
where
  "subtract Tip t = Some t"
| "subtract (Node l x b r) t =
     (case delete x t of
        Some t' \<Rightarrow> (case subtract l t' of
                     Some t'' \<Rightarrow> subtract r t''
                    | None \<Rightarrow> None)
       | None \<Rightarrow> None)"

lemma subtract_Some_set_of_res:
  "subtract t\<^sub>1 t\<^sub>2 = Some t \<Longrightarrow> set_of t \<subseteq> set_of t\<^sub>2"
proof (induct t\<^sub>1 arbitrary: t\<^sub>2 t)
  case Tip thus ?case by simp
next
  case (Node l x b r)
  have sub: "subtract (Node l x b r) t\<^sub>2 = Some t" by fact
  show ?case
  proof (cases "delete x t\<^sub>2")
    case (Some t\<^sub>2')
    note del_x_Some = this
    from delete_Some_set_of [OF Some]
    have t2'_t2: "set_of t\<^sub>2' \<subseteq> set_of t\<^sub>2" .
    show ?thesis
    proof (cases "subtract l t\<^sub>2'")
      case (Some t\<^sub>2'')
      note sub_l_Some = this
      from Node.hyps (1) [OF Some]
      have t2''_t2': "set_of t\<^sub>2'' \<subseteq> set_of t\<^sub>2'" .
      show ?thesis
      proof (cases "subtract r t\<^sub>2''")
        case (Some t\<^sub>2''')
        from Node.hyps (2) [OF Some ]
        have "set_of t\<^sub>2''' \<subseteq> set_of t\<^sub>2''" .
        with Some sub_l_Some del_x_Some sub t2''_t2' t2'_t2
        show ?thesis
          by simp
      next
        case None
        with del_x_Some sub_l_Some sub
        show ?thesis
          by simp
      qed
    next
      case None
      with del_x_Some sub
      show ?thesis
        by simp
    qed
  next
    case None
    with sub show ?thesis by simp
  qed
qed

lemma subtract_Some_set_of:
  "subtract t\<^sub>1 t\<^sub>2 = Some t \<Longrightarrow> set_of t\<^sub>1 \<subseteq> set_of t\<^sub>2"
proof (induct t\<^sub>1 arbitrary: t\<^sub>2 t)
  case Tip thus ?case by simp
next
  case (Node l x d r)
  have sub: "subtract (Node l x d r) t\<^sub>2 = Some t" by fact
  show ?case
  proof (cases "delete x t\<^sub>2")
    case (Some t\<^sub>2')
    note del_x_Some = this
    from delete_Some_set_of [OF Some]
    have t2'_t2: "set_of t\<^sub>2' \<subseteq> set_of t\<^sub>2" .
    from delete_None_set_of_conv [of x t\<^sub>2] Some
    have x_t2: "x \<in> set_of t\<^sub>2"
      by simp
    show ?thesis
    proof (cases "subtract l t\<^sub>2'")
      case (Some t\<^sub>2'')
      note sub_l_Some = this
      from Node.hyps (1) [OF Some]
      have l_t2': "set_of l \<subseteq> set_of t\<^sub>2'" .
      from subtract_Some_set_of_res [OF Some]
      have t2''_t2': "set_of t\<^sub>2'' \<subseteq> set_of t\<^sub>2'" .
      show ?thesis
      proof (cases "subtract r t\<^sub>2''")
        case (Some t\<^sub>2''')
        from Node.hyps (2) [OF Some ]
        have r_t\<^sub>2'': "set_of r \<subseteq> set_of t\<^sub>2''" .
        from Some sub_l_Some del_x_Some sub r_t\<^sub>2'' l_t2' t2'_t2 t2''_t2' x_t2
        show ?thesis
          by auto
      next
        case None
        with del_x_Some sub_l_Some sub
        show ?thesis
          by simp
      qed
    next
      case None
      with del_x_Some sub
      show ?thesis
        by simp
    qed
  next
    case None
    with sub show ?thesis by simp
  qed
qed

lemma subtract_Some_all_distinct_res:
  "subtract t\<^sub>1 t\<^sub>2 = Some t \<Longrightarrow> all_distinct t\<^sub>2 \<Longrightarrow> all_distinct t"
proof (induct t\<^sub>1 arbitrary: t\<^sub>2 t)
  case Tip thus ?case by simp
next
  case (Node l x d r)
  have sub: "subtract (Node l x d r) t\<^sub>2 = Some t" by fact
  have dist_t2: "all_distinct t\<^sub>2" by fact
  show ?case
  proof (cases "delete x t\<^sub>2")
    case (Some t\<^sub>2')
    note del_x_Some = this
    from delete_Some_all_distinct [OF Some dist_t2]
    have dist_t2': "all_distinct t\<^sub>2'" .
    show ?thesis
    proof (cases "subtract l t\<^sub>2'")
      case (Some t\<^sub>2'')
      note sub_l_Some = this
      from Node.hyps (1) [OF Some dist_t2']
      have dist_t2'': "all_distinct t\<^sub>2''" .
      show ?thesis
      proof (cases "subtract r t\<^sub>2''")
        case (Some t\<^sub>2''')
        from Node.hyps (2) [OF Some dist_t2'']
        have dist_t2''': "all_distinct t\<^sub>2'''" .
        from Some sub_l_Some del_x_Some sub
             dist_t2'''
        show ?thesis
          by simp
      next
        case None
        with del_x_Some sub_l_Some sub
        show ?thesis
          by simp
      qed
    next
      case None
      with del_x_Some sub
      show ?thesis
        by simp
    qed
  next
    case None
    with sub show ?thesis by simp
  qed
qed

lemma subtract_Some_dist_res:
  "subtract t\<^sub>1 t\<^sub>2 = Some t \<Longrightarrow> set_of t\<^sub>1 \<inter> set_of t = {}"
proof (induct t\<^sub>1 arbitrary: t\<^sub>2 t)
  case Tip thus ?case by simp
next
  case (Node l x d r)
  have sub: "subtract (Node l x d r) t\<^sub>2 = Some t" by fact
  show ?case
  proof (cases "delete x t\<^sub>2")
    case (Some t\<^sub>2')
    note del_x_Some = this
    from delete_Some_x_set_of [OF Some]
    obtain x_t2: "x \<in> set_of t\<^sub>2" and x_not_t2': "x \<notin> set_of t\<^sub>2'"
      by simp
    from delete_Some_set_of [OF Some]
    have t2'_t2: "set_of t\<^sub>2' \<subseteq> set_of t\<^sub>2" .
    show ?thesis
    proof (cases "subtract l t\<^sub>2'")
      case (Some t\<^sub>2'')
      note sub_l_Some = this
      from Node.hyps (1) [OF Some ]
      have dist_l_t2'': "set_of l \<inter> set_of t\<^sub>2'' = {}".
      from subtract_Some_set_of_res [OF Some]
      have t2''_t2': "set_of t\<^sub>2'' \<subseteq> set_of t\<^sub>2'" .
      show ?thesis
      proof (cases "subtract r t\<^sub>2''")
        case (Some t\<^sub>2''')
        from Node.hyps (2) [OF Some]
        have dist_r_t2''': "set_of r \<inter> set_of t\<^sub>2''' = {}" .
        from subtract_Some_set_of_res [OF Some]
        have t2'''_t2'': "set_of t\<^sub>2''' \<subseteq> set_of t\<^sub>2''".

        from Some sub_l_Some del_x_Some sub t2'''_t2'' dist_l_t2'' dist_r_t2'''
             t2''_t2' t2'_t2 x_not_t2'
        show ?thesis
          by auto
      next
        case None
        with del_x_Some sub_l_Some sub
        show ?thesis
          by simp
      qed
    next
      case None
      with del_x_Some sub
      show ?thesis
        by simp
    qed
  next
    case None
    with sub show ?thesis by simp
  qed
qed

lemma subtract_Some_all_distinct:
  "subtract t\<^sub>1 t\<^sub>2 = Some t \<Longrightarrow> all_distinct t\<^sub>2 \<Longrightarrow> all_distinct t\<^sub>1"
proof (induct t\<^sub>1 arbitrary: t\<^sub>2 t)
  case Tip thus ?case by simp
next
  case (Node l x d r)
  have sub: "subtract (Node l x d r) t\<^sub>2 = Some t" by fact
  have dist_t2: "all_distinct t\<^sub>2" by fact
  show ?case
  proof (cases "delete x t\<^sub>2")
    case (Some t\<^sub>2')
    note del_x_Some = this
    from delete_Some_all_distinct [OF Some dist_t2 ]
    have dist_t2': "all_distinct t\<^sub>2'" .
    from delete_Some_set_of [OF Some]
    have t2'_t2: "set_of t\<^sub>2' \<subseteq> set_of t\<^sub>2" .
    from delete_Some_x_set_of [OF Some]
    obtain x_t2: "x \<in> set_of t\<^sub>2" and x_not_t2': "x \<notin> set_of t\<^sub>2'"
      by simp

    show ?thesis
    proof (cases "subtract l t\<^sub>2'")
      case (Some t\<^sub>2'')
      note sub_l_Some = this
      from Node.hyps (1) [OF Some dist_t2' ]
      have dist_l: "all_distinct l" .
      from subtract_Some_all_distinct_res [OF Some dist_t2']
      have dist_t2'': "all_distinct t\<^sub>2''" .
      from subtract_Some_set_of [OF Some]
      have l_t2': "set_of l \<subseteq> set_of t\<^sub>2'" .
      from subtract_Some_set_of_res [OF Some]
      have t2''_t2': "set_of t\<^sub>2'' \<subseteq> set_of t\<^sub>2'" .
      from subtract_Some_dist_res [OF Some]
      have dist_l_t2'': "set_of l \<inter> set_of t\<^sub>2'' = {}".
      show ?thesis
      proof (cases "subtract r t\<^sub>2''")
        case (Some t\<^sub>2''')
        from Node.hyps (2) [OF Some dist_t2'']
        have dist_r: "all_distinct r" .
        from subtract_Some_set_of [OF Some]
        have r_t2'': "set_of r \<subseteq> set_of t\<^sub>2''" .
        from subtract_Some_dist_res [OF Some]
        have dist_r_t2''': "set_of r \<inter> set_of t\<^sub>2''' = {}".

        from dist_l dist_r Some sub_l_Some del_x_Some r_t2'' l_t2' x_t2 x_not_t2'
             t2''_t2' dist_l_t2'' dist_r_t2'''
        show ?thesis
          by auto
      next
        case None
        with del_x_Some sub_l_Some sub
        show ?thesis
          by simp
      qed
    next
      case None
      with del_x_Some sub
      show ?thesis
        by simp
    qed
  next
    case None
    with sub show ?thesis by simp
  qed
qed

lemma delete_left:
  assumes dist: "all_distinct (Node l y d r)"
  assumes del_l: "delete x l = Some l'"
  shows "delete x (Node l y d r) = Some (Node l' y d r)"
proof -
  from delete_Some_x_set_of [OF del_l]
  obtain x: "x \<in> set_of l"
    by simp
  with dist
  have "delete x r = None"
    by (cases "delete x r") (auto dest:delete_Some_x_set_of)

  with x
  show ?thesis
    using del_l dist
    by (auto split: option.splits)
qed

lemma delete_right:
  assumes dist: "all_distinct (Node l y d r)"
  assumes del_r: "delete x r = Some r'"
  shows "delete x (Node l y d r) = Some (Node l y d r')"
proof -
  from delete_Some_x_set_of [OF del_r]
  obtain x: "x \<in> set_of r"
    by simp
  with dist
  have "delete x l = None"
    by (cases "delete x l") (auto dest:delete_Some_x_set_of)

  with x
  show ?thesis
    using del_r dist
    by (auto split: option.splits)
qed

lemma delete_root:
  assumes dist: "all_distinct (Node l x False r)"
  shows "delete x (Node l x False r) = Some (Node l x True r)"
proof -
  from dist have "delete x r = None"
    by (cases "delete x r") (auto dest:delete_Some_x_set_of)
  moreover
  from dist have "delete x l = None"
    by (cases "delete x l") (auto dest:delete_Some_x_set_of)
  ultimately show ?thesis
    using dist
       by (auto split: option.splits)
qed

lemma subtract_Node:
 assumes del: "delete x t = Some t'"
 assumes sub_l: "subtract l t' = Some t''"
 assumes sub_r: "subtract r t'' = Some t'''"
 shows "subtract (Node l x False r) t = Some t'''"
using del sub_l sub_r
by simp

lemma subtract_Tip: "subtract Tip t = Some t"
  by simp

text \<open>Now we have all the theorems in place that are needed for the
certificate generating ML functions.\<close>

ML_file \<open>distinct_tree_prover.ML\<close>

end