(*
    Author:      René Thiemann
                 Akihisa Yamada
    License:     BSD
*)
section \<open>Show for Real Algebraic Numbers -- Interface\<close>

text \<open>We just demand that there is some function from real algebraic numbers to string and register this
  as show-function and use it to implement \textit{show-real}.

  Implementations for real algebraic numbers are available in one of the theories \textit{Show-Real-Precise}
  and \textit{Show-Real-Approx}.\<close>
theory Show_Real_Alg
imports
  Real_Algebraic_Numbers
  Show.Show_Real
begin

consts show_real_alg :: "real_alg \<Rightarrow> string"

definition showsp_real_alg :: "real_alg showsp" where
  "showsp_real_alg p x y = (show_real_alg x @ y)"

lemma show_law_real_alg [show_law_intros]:
  "show_law showsp_real_alg r"
  by (rule show_lawI) (simp add: showsp_real_alg_def show_law_simps)

lemma showsp_real_alg_append [show_law_simps]:
  "showsp_real_alg p r (x @ y) = showsp_real_alg p r x @ y"
  by (intro show_lawD show_law_intros)

local_setup \<open>
  Show_Generator.register_foreign_showsp @{typ real_alg} @{term "showsp_real_alg"} @{thm show_law_real_alg}
\<close>

derive "show" real_alg

text \<open>We now define @{const show_real}.\<close>
overloading show_real \<equiv> show_real
begin
  definition "show_real \<equiv> show_real_alg o real_alg_of_real"
end

end


(* Verification of imperative red-black trees. *)

theory IHT_Red_Black_Tree
  imports
    Auto2_Imperative_HOL.RBTree
    "../SepLogicTime/SLTC_Main"
    "../Asymptotics/Asymptotics_2D"
begin

section \<open>Tree nodes\<close>

datatype ('a, 'b) rbt_node =
  Node (lsub: "('a, 'b) rbt_node ref option") (cl: color) (key: 'a) (val: 'b) (rsub: "('a, 'b) rbt_node ref option")
setup \<open>fold add_rewrite_rule @{thms rbt_node.sel}\<close>

fun color_encode :: "color \<Rightarrow> nat" where
  "color_encode B = 0"
| "color_encode R = 1"

instance color :: heap
  apply (rule heap_class.intro)
  apply (rule countable_classI [of "color_encode"])
  apply (metis color_encode.simps(1) color_encode.simps(2) not_B zero_neq_one)
  ..

fun rbt_node_encode :: "('a::heap, 'b::heap) rbt_node \<Rightarrow> nat" where
  "rbt_node_encode (Node l c k v r) = to_nat (l, c, k, v, r)"

instance rbt_node :: (heap, heap) heap
  apply (rule heap_class.intro)
  apply (rule countable_classI [of "rbt_node_encode"])
  apply (case_tac x, simp_all, case_tac y, simp_all)
  ..

fun btree :: "('a::heap, 'b::heap) rbt \<Rightarrow> ('a, 'b) rbt_node ref option \<Rightarrow> assn" where
  "btree Leaf p = \<up>(p = None)"
| "btree (rbt.Node lt c k v rt) (Some p) = (\<exists>\<^sub>Alp rp. p \<mapsto>\<^sub>r Node lp c k v rp * btree lt lp * btree rt rp)"
| "btree (rbt.Node lt c k v rt) None = false"
setup \<open>fold add_rewrite_ent_rule @{thms btree.simps}\<close>

lemma btree_Leaf [forward_ent]: "btree Leaf p \<Longrightarrow>\<^sub>A \<up>(p = None)" by auto2

lemma btree_Node [forward_ent]:
  "btree (rbt.Node lt c k v rt) p \<Longrightarrow>\<^sub>A (\<exists>\<^sub>Alp rp. the p \<mapsto>\<^sub>r Node lp c k v rp * btree lt lp * btree rt rp * \<up>(p \<noteq> None))"
@proof @case "p = None" @qed

lemma btree_none: "emp \<Longrightarrow>\<^sub>A btree Leaf None" by auto2

lemma btree_constr_ent:
  "p \<mapsto>\<^sub>r Node lp c k v rp * btree lt lp * btree rt rp \<Longrightarrow>\<^sub>A btree (rbt.Node lt c k v rt) (Some p)" by auto2

setup \<open>fold add_entail_matcher [@{thm btree_none}, @{thm btree_constr_ent}]\<close>
setup \<open>fold del_prfstep_thm @{thms btree.simps}\<close>

type_synonym ('a, 'b) btree = "('a, 'b) rbt_node ref option"

section \<open>Operations\<close>

subsection \<open>Basic operations\<close>

definition tree_empty :: "('a, 'b) btree Heap" where
  "tree_empty = return None"

lemma tree_empty_rule [hoare_triple]:
  "<$1> tree_empty <btree Leaf>" by auto2

definition tree_is_empty :: "('a, 'b) btree \<Rightarrow> bool Heap" where
  "tree_is_empty b = return (b = None)"

definition btree_constr ::
  "('a::heap, 'b::heap) btree \<Rightarrow> color \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> ('a, 'b) btree \<Rightarrow> ('a, 'b) btree Heap" where
  "btree_constr lp c k v rp = do { p \<leftarrow> ref (Node lp c k v rp); return (Some p) }"

lemma btree_constr_rule [hoare_triple]:
  "<btree lt lp * btree rt rp * $2>
   btree_constr lp c k v rp
   <btree (rbt.Node lt c k v rt)>" by auto2

definition set_color :: "color \<Rightarrow> ('a::heap, 'b::heap) btree \<Rightarrow> unit Heap" where
  "set_color c p = (case p of
    None \<Rightarrow> raise ''set_color''
  | Some pp \<Rightarrow> do {
      t \<leftarrow> !pp;
      pp := Node (lsub t) c (key t) (val t) (rsub t)
    })"

lemma set_color_rule [hoare_triple]:
  "<btree (rbt.Node a c x v b) p * $2>
   set_color c' p
   <\<lambda>_. btree (rbt.Node a c' x v b) p>\<^sub>t" by auto2

definition get_color :: "('a::heap, 'b::heap) btree \<Rightarrow> color Heap" where
  "get_color p = (case p of
     None \<Rightarrow> return B
   | Some pp \<Rightarrow> do {
       t \<leftarrow> !pp;
       return (cl t)
     })"

definition paint :: "color \<Rightarrow> ('a::heap, 'b::heap) btree \<Rightarrow> unit Heap" where
  "paint c p = (case p of
    None \<Rightarrow> return ()
  | Some pp \<Rightarrow> do {
     t \<leftarrow> !pp;
     pp := Node (lsub t) c (key t) (val t) (rsub t)
   })"

lemma paint_rule [hoare_triple]:
  "<btree t p *$2>
   paint c p
   <\<lambda>_. btree (RBTree.paint c t) p>\<^sub>t"
@proof @case "t = Leaf" @qed

subsection \<open>Rotation\<close>

definition btree_rotate_l :: "('a::heap, 'b::heap) btree \<Rightarrow> ('a, 'b) btree Heap" where
  "btree_rotate_l p = (case p of
    None \<Rightarrow> raise ''Empty btree''
  | Some pp \<Rightarrow> do {
     t \<leftarrow> !pp;
     (case rsub t of
        None \<Rightarrow> raise ''Empty rsub''
      | Some rp \<Rightarrow> do {
          rt \<leftarrow> !rp;
          pp := Node (lsub t) (cl t) (key t) (val t) (lsub rt);
          rp := Node p (cl rt) (key rt) (val rt) (rsub rt);
          return (rsub t) })})"

lemma btree_rotate_l_rule [hoare_triple]:
  "<btree (rbt.Node a c1 x v (rbt.Node b c2 y w c)) p * $5>
   btree_rotate_l p
   <btree (rbt.Node (rbt.Node a c1 x v b) c2 y w c)>\<^sub>t" by auto2

definition btree_rotate_r :: "('a::heap, 'b::heap) btree \<Rightarrow> ('a, 'b) btree Heap" where
  "btree_rotate_r p = (case p of
    None \<Rightarrow> raise ''Empty btree''
  | Some pp \<Rightarrow> do {
     t \<leftarrow> !pp;
     (case lsub t of
        None \<Rightarrow> raise ''Empty lsub''
      | Some lp \<Rightarrow> do {
          lt \<leftarrow> !lp;
          pp := Node (rsub lt) (cl t) (key t) (val t) (rsub t);
          lp := Node (lsub lt) (cl lt) (key lt) (val lt) p;
          return (lsub t) })})"

definition btree_rotate_r_time :: "nat" where [rewrite]: "btree_rotate_r_time = 5"

lemma btree_rotate_r_rule [hoare_triple]:
  "<btree (rbt.Node (rbt.Node a c1 x v b) c2 y w c) p * $5>
   btree_rotate_r p
   <btree (rbt.Node a c1 x v (rbt.Node b c2 y w c))>" by auto2

lemma btree_rotate_r_time_bound [asym_bound]:
  "(\<lambda>n::nat. btree_rotate_r_time) \<in> \<Theta>(\<lambda>n. 1)"
  apply (simp only: btree_rotate_r_time_def) by auto2

subsection \<open>Balance\<close>

definition btree_balanceR :: "('a::heap, 'b::heap) btree \<Rightarrow> ('a, 'b) btree Heap" where
  "btree_balanceR p = (case p of None \<Rightarrow> return None | Some pp \<Rightarrow> do {
     t \<leftarrow> !pp;
     cl_r \<leftarrow> get_color (rsub t);
     if cl_r = R then do {
       rt \<leftarrow> !(the (rsub t));
       cl_lr \<leftarrow> get_color (lsub rt);
       cl_rr \<leftarrow> get_color (rsub rt);
       if cl_lr = R then do {
         rp' \<leftarrow> btree_rotate_r (rsub t);
         pp := Node (lsub t) (cl t) (key t) (val t) rp';
         p' \<leftarrow> btree_rotate_l p;
         t' \<leftarrow> !(the p');
         set_color B (rsub t');
         return p'
       } else if cl_rr = R then do {
         p' \<leftarrow> btree_rotate_l p;
         t' \<leftarrow> !(the p');
         set_color B (rsub t');
         return p'
        } else return p }
     else return p})"

definition btree_balanceR_time :: "nat" where [rewrite]:
  "btree_balanceR_time = 24"

lemma balanceR_to_fun [hoare_triple]:
  "<btree (rbt.Node l B k v r) p * $24>
   btree_balanceR p
   <btree (balanceR l k v r)>\<^sub>t"
@proof @unfold "balanceR l k v r" @qed

definition btree_balance :: "('a::heap, 'b::heap) btree \<Rightarrow> ('a, 'b) btree Heap" where
  "btree_balance p = (case p of None \<Rightarrow> return None | Some pp \<Rightarrow> do {
     t \<leftarrow> !pp;
     cl_l \<leftarrow> get_color (lsub t);
     if cl_l = R then do {
       lt \<leftarrow> !(the (lsub t));
       cl_rl \<leftarrow> get_color (rsub lt);
       cl_ll \<leftarrow> get_color (lsub lt);
       if cl_ll = R then do {
         p' \<leftarrow> btree_rotate_r p;
         t' \<leftarrow> !(the p');
         set_color B (lsub t');
         return p' }
       else if cl_rl = R then do {
         lp' \<leftarrow> btree_rotate_l (lsub t);
         pp := Node lp' (cl t) (key t) (val t) (rsub t);
         p' \<leftarrow> btree_rotate_r p;
         t' \<leftarrow> !(the p');
         set_color B (lsub t');
         return p'
       } else btree_balanceR p }
     else do {
       p' \<leftarrow> btree_balanceR p;
       return p'}})"
declare [[print_trace]]

subsection \<open>Insertion\<close>

partial_function (heap_time) rbt_ins ::
  "'a::{heap,ord} \<Rightarrow> 'b::heap \<Rightarrow> ('a, 'b) btree \<Rightarrow> ('a, 'b) btree Heap" where
  "rbt_ins k v p = (case p of
     None \<Rightarrow> btree_constr None R k v None
   | Some pp \<Rightarrow> do {
      t \<leftarrow> !pp;
      (if cl t = B then
        (if k = key t then do {
           pp := Node (lsub t) (cl t) k v (rsub t);
           return (Some pp) }
         else if k < key t then do {
           q \<leftarrow> rbt_ins k v (lsub t);
           pp := Node q (cl t) (key t) (val t) (rsub t);
           btree_balance p }
         else do {
           q \<leftarrow> rbt_ins k v (rsub t);
           pp := Node (lsub t) (cl t) (key t) (val t) q;
           btree_balance p })
       else
        (if k = key t then do {
           pp := Node (lsub t) (cl t) k v (rsub t);
           return (Some pp) }
         else if k < key t then do {
           q \<leftarrow> rbt_ins k v (lsub t);
           pp := Node q (cl t) (key t) (val t) (rsub t);
           return (Some pp) }
         else do {
           q \<leftarrow> rbt_ins k v (rsub t);
           pp := Node (lsub t) (cl t) (key t) (val t) q;
           return (Some pp) }))})"

fun rbt_ins_time' :: "('a, 'b) rbt \<Rightarrow> 'a::ord \<Rightarrow> nat" where
    "rbt_ins_time' Leaf k = 4"
  | "rbt_ins_time' (rbt.Node l c ka va r) k = (if c=B
       then
       (if k=ka then 4 else (if k<ka then 50 + rbt_ins_time' l k else 100 + rbt_ins_time' r k))
        else
       (if k=ka then 4 else (if k<ka then 100 + rbt_ins_time' l k else 100 + rbt_ins_time' r k)) ) "
setup \<open>fold add_rewrite_rule @{thms rbt_ins_time'.simps}\<close>

lemma rbt_ins_to_fun'[hoare_triple]:
  "<btree t p *  $(rbt_ins_time' t k)>
   rbt_ins k v p
   <btree (ins k v t)>\<^sub>t"
@proof @induct t arbitrary p @qed

definition rbt_ins_time :: "nat \<Rightarrow> nat" where
    "rbt_ins_time n = 400 * n + 4"

lemma rbt_ins_time'[resolve]: "rbt_ins_time' t k \<le> rbt_ins_time (max_depth t)"
  by (induct t, auto simp: rbt_ins_time_def)

lemma rbt_ins_to_fun[hoare_triple]:
  "<btree t p * $(rbt_ins_time (max_depth t))>
   rbt_ins k v p
   <btree (ins k v t)>\<^sub>t"
@proof
  @have "(rbt_ins_time (max_depth t)) \<ge>\<^sub>t rbt_ins_time' t k"
@qed

definition rbt_insert ::
  "'a::{heap,ord} \<Rightarrow> 'b::heap \<Rightarrow> ('a, 'b) btree \<Rightarrow> ('a, 'b) btree Heap" where
  "rbt_insert k v p = do {
    p' \<leftarrow> rbt_ins k v p;
    paint B p';
    return p' }"

definition rbt_insert_time :: "nat \<Rightarrow> nat" where [rewrite]:
    "rbt_insert_time n = rbt_ins_time n + 4"

lemma rbt_insert_to_fun [hoare_triple]:
  "<btree t p * $(rbt_insert_time (max_depth t))>
   rbt_insert k v p
   <btree (RBTree.rbt_insert k v t)>\<^sub>t" by auto2

subsection \<open>Search\<close>

partial_function (heap_time) rbt_search ::
  "'a::{heap,linorder} \<Rightarrow> ('a, 'b::heap) btree \<Rightarrow> 'b option Heap" where
  "rbt_search x b = (case b of
     None \<Rightarrow> return None
   | Some p \<Rightarrow> do {
      t \<leftarrow> !p;
      (if x = key t then return (Some (val t))
       else if x < key t then rbt_search x (lsub t)
       else rbt_search x (rsub t)) })"

fun rbt_search_time' :: "('a, 'b) rbt \<Rightarrow> 'a::ord \<Rightarrow> nat" where
    "rbt_search_time' Leaf k = 1"
  | "rbt_search_time' (rbt.Node l c ka va r) k =
       (if k=ka then 2 else (if k<ka then 1 + rbt_search_time' l k else 1 + rbt_search_time' r k))   "
setup \<open>fold add_rewrite_rule @{thms rbt_search_time'.simps}\<close>

lemma btree_search_correct' [hoare_triple]: (* order of \<up> and $ is important *)
  "<btree t b  * $(rbt_search_time' t x) * \<up>(rbt_sorted t)>
   rbt_search x b
   <\<lambda>r. btree t b * \<up>(r = RBTree.rbt_search t x)>\<^sub>t"
@proof @induct t arbitrary b @qed

abbreviation "searchC == 40"
definition rbt_search_time :: "nat \<Rightarrow> nat" where [rewrite]:
    "rbt_search_time n = searchC * n + 4"

lemma rbt_search_time_ub[resolve]: "rbt_search_time (max_depth t) \<ge> rbt_search_time' t k"
  by(induct t, auto simp: rbt_search_time_def)

lemma btree_search_correct [hoare_triple]:
  "<btree t b  * $(rbt_search_time (max_depth t)) * \<up>(rbt_sorted t)>
   rbt_search x b
   <\<lambda>r. btree t b * \<up>(r = RBTree.rbt_search t x)>\<^sub>t"
@proof @have "rbt_search_time (max_depth t) \<ge>\<^sub>t rbt_search_time' t x" @qed

setup \<open>del_prfstep_thm @{thm rbt_search_time_def}\<close>

subsection \<open>Delete\<close>

definition btree_balL :: "('a::heap, 'b::heap) btree \<Rightarrow> ('a, 'b) btree Heap" where
  "btree_balL p = (case p of
     None \<Rightarrow> return None
   | Some pp \<Rightarrow> do {
      t \<leftarrow> !pp;
      cl_l \<leftarrow> get_color (lsub t);
      if cl_l = R then do {
        set_color B (lsub t);   \<comment> \<open> case 1 \<close>
        return p}
      else case rsub t of
        None \<Rightarrow> return p  \<comment> \<open> case 2\<close>
      | Some rp \<Rightarrow> do {
         rt \<leftarrow> !rp;
         if cl rt = B then do {
           set_color R (rsub t);  \<comment> \<open> case 3\<close>
           set_color B p;
           btree_balance p}
         else case lsub rt of
           None \<Rightarrow> return p  \<comment> \<open> case 4 \<close>
         | Some lrp \<Rightarrow> do {
            lrt \<leftarrow> !lrp;
            if cl lrt = B then do {
              set_color R (lsub rt); \<comment> \<open> case 5 \<close>
              paint R (rsub rt);
              set_color B (rsub t);
              rp' \<leftarrow> btree_rotate_r (rsub t);
              pp := Node (lsub t) (cl t) (key t) (val t) rp';
              p' \<leftarrow> btree_rotate_l p;
              t' \<leftarrow> !(the p');
              set_color B (lsub t');
              rp'' \<leftarrow> btree_balance (rsub t');
              the p' := Node (lsub t') (cl t') (key t') (val t') rp'';
              return p'}
            else return p}}})"

lemma balL_to_fun [hoare_triple]:
  "<btree (rbt.Node l R k v r) p * $60 >
   btree_balL p
   <btree (balL l k v r)>\<^sub>t"
@proof @unfold "balL l k v r" @qed

definition btree_balR :: "('a::heap, 'b::heap) btree \<Rightarrow> ('a, 'b) btree Heap" where
  "btree_balR p = (case p of
     None \<Rightarrow> return None
   | Some pp \<Rightarrow> do {
      t \<leftarrow> !pp;
      cl_r \<leftarrow> get_color (rsub t);
      if cl_r = R then do {
        set_color B (rsub t);  \<comment>\<open>case 1 \<close>
        return p}
      else case lsub t of
        None \<Rightarrow> return p   \<comment>\<open>case 2\<close>
      | Some lp \<Rightarrow> do {
         lt \<leftarrow> !lp;
         if cl lt = B then do {
           set_color R (lsub t);   \<comment>\<open>case 3\<close>
           set_color B p;
           btree_balance p}
         else case rsub lt of
           None \<Rightarrow> return p   \<comment>\<open>case 4\<close>
         | Some rlp \<Rightarrow> do {
            rlt \<leftarrow> !rlp;
            if cl rlt = B then do {
              set_color R (rsub lt);   \<comment>\<open>case 5\<close>
              paint R (lsub lt);
              set_color B (lsub t);
              lp' \<leftarrow> btree_rotate_l (lsub t);
              pp := Node lp' (cl t) (key t) (val t) (rsub t);
              p' \<leftarrow> btree_rotate_r p;
              t' \<leftarrow> !(the p');
              set_color B (rsub t');
              lp'' \<leftarrow> btree_balance (lsub t');
              the p' := Node lp'' (cl t') (key t') (val t') (rsub t');
              return p'}
            else return p}}})"

lemma balR_to_fun [hoare_triple]:
  "<btree (rbt.Node l R k v r) p * $60>
   btree_balR p
   <btree (balR l k v r)>\<^sub>t"
@proof @unfold "balR l k v r" @qed

partial_function (heap_time) btree_combine ::
  "('a::heap, 'b::heap) btree \<Rightarrow> ('a, 'b) btree \<Rightarrow> ('a, 'b) btree Heap" where
  "btree_combine lp rp =
   (if lp = None then return rp
    else if rp = None then return lp
    else do {
      lt \<leftarrow> !(the lp);
      rt \<leftarrow> !(the rp);
      if cl lt = R then
        if cl rt = R then do {
          tmp \<leftarrow> btree_combine (rsub lt) (lsub rt);
          cl_tm \<leftarrow> get_color tmp;
          if cl_tm = R then do {
            tmt \<leftarrow> !(the tmp);
            the lp := Node (lsub lt) R (key lt) (val lt) (lsub tmt);
            the rp := Node (rsub tmt) R (key rt) (val rt) (rsub rt);
            the tmp := Node lp R (key tmt) (val tmt) rp;
            return tmp}
          else do {
            the rp := Node tmp R (key rt) (val rt) (rsub rt);
            the lp := Node (lsub lt) R (key lt) (val lt) rp;
            return lp}}
        else do {
          tmp \<leftarrow> btree_combine (rsub lt) rp;
          the lp := Node (lsub lt) R (key lt) (val lt) tmp;
          return lp}
      else if cl rt = B then do {
        tmp \<leftarrow> btree_combine (rsub lt) (lsub rt);
        cl_tm \<leftarrow> get_color tmp;
        if cl_tm = R then do {
          tmt \<leftarrow> !(the tmp);
          the lp := Node (lsub lt) B (key lt) (val lt) (lsub tmt);
          the rp := Node (rsub tmt) B (key rt) (val rt) (rsub rt);
          the tmp := Node lp R (key tmt) (val tmt) rp;
          return tmp}
        else do {
          the rp := Node tmp B (key rt) (val rt) (rsub rt);
          the lp := Node (lsub lt) R (key lt) (val lt) rp;
          btree_balL lp}}
      else do {
        tmp \<leftarrow> btree_combine lp (lsub rt);
        the rp := Node tmp R (key rt) (val rt) (rsub rt);
        return rp}})"

fun rbt_combine_time' :: "('a, 'b) rbt \<Rightarrow> ('a, 'b) rbt \<Rightarrow> nat" where
    "rbt_combine_time' Leaf _ = 1"
  | "rbt_combine_time' (rbt.Node l c ka va r) Leaf = 1"
  | "rbt_combine_time' (rbt.Node l1 c1 k1 v1 r1) (rbt.Node l2 c2 k2 v2 r2) =
      (if c1=R then
         (if c2=R then 20 +  rbt_combine_time' r1 l2
             else 20 +  rbt_combine_time' r1 (rbt.Node l2 c2 k2 v2 r2) )
        else
          (if c2=B then 80 +  rbt_combine_time' r1 l2
              else 20 + rbt_combine_time' (rbt.Node l1 c1 k1 v1 r1) l2)
           )   "
setup \<open>fold add_rewrite_rule @{thms rbt_combine_time'.simps}\<close>

lemma combine_to_fun' [hoare_triple]:
  "<btree lt lp * btree rt rp * $(rbt_combine_time' lt rt)>
   btree_combine lp rp
   <btree (combine lt rt)>\<^sub>t"
@proof @fun_induct "combine lt rt" arbitrary lp rp @with
  @subgoal "(lt = rbt.Node l1 c1 k1 v1 r1, rt = rbt.Node l2 c2 k2 v2 r2)"
    @unfold "combine (rbt.Node l1 c1 k1 v1 r1) (rbt.Node l2 c2 k2 v2 r2)"
  @endgoal @end
@qed

abbreviation "combineC == 40"
definition btree_combine_time :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
  "btree_combine_time n m = combineC * n + combineC * m + 1"

lemma btree_combine_time_ub[resolve]: "btree_combine_time (max_depth t1) (max_depth t2) \<ge> rbt_combine_time' t1 t2"
  apply(induct rule: rbt_combine_time'.induct) by (auto simp: btree_combine_time_def)

lemma combine_to_fun [hoare_triple]:
  "<btree lt lp * btree rt rp * $(btree_combine_time (max_depth lt) (max_depth rt))>
   btree_combine lp rp
   <btree (combine lt rt)>\<^sub>t"
@proof @have "btree_combine_time (max_depth lt) (max_depth rt) \<ge>\<^sub>t rbt_combine_time' lt rt" @qed

partial_function (heap_time) rbt_del ::
  "'a::{heap,linorder} \<Rightarrow> ('a, 'b::heap) btree \<Rightarrow> ('a, 'b) btree Heap" where
  "rbt_del x p = (case p of
     None \<Rightarrow> return None
   | Some pp \<Rightarrow> do {
      t \<leftarrow> !pp;
      (if x = key t then btree_combine (lsub t) (rsub t)
       else if x < key t then case lsub t of
         None \<Rightarrow> do {
           set_color R p;
           return p}
       | Some lp \<Rightarrow> do {
           lt \<leftarrow> !lp;
           if cl lt = B then do {
             q \<leftarrow> rbt_del x (lsub t);
             pp := Node q R (key t) (val t) (rsub t);
             btree_balL p }
           else do {
             q \<leftarrow> rbt_del x (lsub t);
             pp := Node q R (key t) (val t) (rsub t);
             return p }}
       else case rsub t of
         None \<Rightarrow> do {
           set_color R p;
           return p}
       | Some rp \<Rightarrow> do {
           rt \<leftarrow> !rp;
           if cl rt = B then do {
             q \<leftarrow> rbt_del x (rsub t);
             pp := Node (lsub t) R (key t) (val t) q;
             btree_balR p }
           else do {
             q \<leftarrow> rbt_del x (rsub t);
             pp := Node (lsub t) R (key t) (val t) q;
             return p }})})"

fun rbt_del_time' :: "('a, 'b) rbt \<Rightarrow> 'a::ord \<Rightarrow> nat" where
    "rbt_del_time' Leaf _ = 1"
  | "rbt_del_time' (rbt.Node l c ka va r) k  =
      (if k=ka
        then 2 + btree_combine_time (max_depth l) (max_depth r)
        else (if k < ka then
            (if l = Leaf then 10
            else 80 + rbt_del_time' l k)
        else
            (if r = Leaf then 10
            else 80 + rbt_del_time' r k)
        ))
         "
setup \<open>fold add_rewrite_rule @{thms rbt_del_time'.simps}\<close>

lemma rbt_del_to_fun' [hoare_triple]:
  "<btree t p * $(rbt_del_time' t x)>
   rbt_del x p
   <btree (del x t)>\<^sub>t"
@proof @induct t arbitrary p @with
  @subgoal "t = rbt.Node l c k v r"
    @unfold "del x (rbt.Node l c k v r)"
  @endgoal @end
@qed

definition btree_del_time :: "nat \<Rightarrow> nat" where
  "btree_del_time n = 200 * combineC * n + 8"

lemma btree_del_time_ub[resolve]: "btree_del_time (max_depth t) \<ge> rbt_del_time' t k"
  by (induct t, auto simp: btree_del_time_def btree_combine_time_def)

lemma rbt_del_to_fun [hoare_triple]:
  "<btree t p * $(btree_del_time (max_depth t))>
   rbt_del x p
   <btree (del x t)>\<^sub>t"
@proof @have "btree_del_time (max_depth t) \<ge>\<^sub>t rbt_del_time' t x" @qed

definition rbt_delete ::
  "'a::{heap,linorder} \<Rightarrow> ('a, 'b::heap) btree \<Rightarrow> ('a, 'b) btree Heap" where
  "rbt_delete k p = do {
    p' \<leftarrow> rbt_del k p;
    paint B p';
    return p'}"

definition rbt_delete_time :: "nat \<Rightarrow> nat" where [rewrite]:
    "rbt_delete_time n = btree_del_time n + 4"

lemma rbt_delete_to_fun [hoare_triple]:
  "<btree t p * $(rbt_delete_time (max_depth t))>
   rbt_delete k p
   <btree (RBTree.delete k t)>\<^sub>t" by auto2

section \<open>Height-Size Relation\<close>

fun size :: "('a, 'b) rbt \<Rightarrow> nat" where
  "size Leaf = 0"
| "size (rbt.Node l c k v r) =  1 + size l + size r"

definition size1 :: "('a, 'b) rbt \<Rightarrow> nat" where "size1 t = 1 + size t"

lemma bheight_size_bound: "is_rbt t \<Longrightarrow> size1 t \<ge> 2 ^ (black_depth t)"
  apply(induction t) apply simp apply (auto simp: is_rbt_def size1_def )
  subgoal for t1 x2 x3 x4 t2 apply(cases x2)
    by auto done

lemma max_black_aux: "is_rbt t \<Longrightarrow> (if rbt.cl t = R then max_depth t \<le> 2 * black_depth t + 1
                               else max_depth t \<le> 2 * black_depth t)"
@proof @induct t  @with
  @subgoal "t = rbt.Node l c k v r" @case "c = R" @endgoal
  @end
@qed

lemma max_black: "is_rbt t  \<Longrightarrow> (max_depth t -1)/2 \<le>   black_depth t"
  using max_black_aux  apply(cases "rbt.cl t") by fastforce+

lemma rbt_height_le: assumes "is_rbt t" shows "max_depth t \<le> 2 * log 2 (size1 t) + 1"
proof -
  have "2 powr ((max_depth t - 1 )/ 2) \<le> 2 powr black_depth t"
    using max_black[OF assms] by (simp)
  also have "\<dots> \<le> size1 t" using assms
    by (simp add: powr_realpow bheight_size_bound  )
  finally have "2 powr ((max_depth t -1) / 2) \<le> size1 t" .
  hence "(max_depth t -1) / 2 \<le> log 2 (size1 t)"
    by(simp add: le_log_iff size1_def del: divide_le_eq_numeral1(1))
  thus ?thesis by simp
qed

subsection "size1 of operations"

lemma size1Leaf[rewrite]: "size1 Leaf = 1" by (simp add: size1_def)

lemma size1_paint[simp]: "size1 (RBTree.paint b t) = size1 t" by(induct t, auto simp: size1_def)
lemma size_paint[simp]: "size (RBTree.paint b t) = size t" by(induct t, auto)

lemma size_red_subs: "rbt.cl t = R \<Longrightarrow> size t = size (rbt.lsub t) + size (rbt.rsub t) + 1"
   apply(cases t) by auto

lemma size_balanceR[simp]: "size (RBTree.balanceR l k v r) = 1 + size l + size r"
  apply( auto simp: balanceR_def)
  apply(cases "rbt.cl (rbt.lsub r)") by (auto simp: Let_def size_red_subs)

lemma size_balance[simp]: "size (RBTree.balance l k v r) = 1 + size l + size r"
  by (auto simp: balance_def Let_def size_red_subs)

lemma size1_ins[simp]: "size1 (RBTree.ins k v t) \<le> size1 t + 1" by (induct t, auto simp: size1_def)

lemma size1_rbt_insert[resolve]: "size1 (RBTree.rbt_insert k v t) \<le> size1 t + 1"
  apply(simp add: RBTree.rbt_insert_def) using size1_ins by simp

section \<open>size of map\<close>

lemma map_of_alist_conc: "(map_of_alist (xs @ ys)) = Map (\<lambda>k.
     (case meval (map_of_alist xs) k of None \<Rightarrow> meval (map_of_alist ys) k
                                       | Some v \<Rightarrow> Some v))"
  by(induct xs, auto intro: meval_ext simp: empty_map_def update_map_def)

lemma rbt_set_keys_of: "rbt_sorted t \<Longrightarrow> keys_of (rbt_map t) = rbt_set t"
proof(induct t)
  case Leaf
  then show ?case by ( auto simp: rbt_map_def empty_map_def keys_of_def)
next
  case (Node t1 x2 x3 x4 t2)
  have i: " keys_of (rbt_map (rbt.Node t1 x2 x3 x4 t2))
          = keys_of (rbt_map t1) \<union> {x3} \<union> (keys_of (rbt_map t2))"
    unfolding keys_of_def rbt_map_def by (auto split: option.split simp: map_of_alist_conc update_map_def)
  from Node show ?case unfolding i by auto
qed

lemma [simp]: "finite (rbt_set t)" by(induct t, auto)

lemma rbt_map_card: "rbt_sorted (rbt.Node l c k v r) \<Longrightarrow>
     card (keys_of (rbt_map (rbt.Node l c k v r))) = card (keys_of (rbt_map l)) + 1 + card (keys_of (rbt_map r))"
proof -
  assume r: "rbt_sorted (rbt.Node l c k v r)"
  from r have [simp]: "rbt_set l \<inter> rbt_set r = {}" by (auto 3 4)
  from r have "card (rbt_set (rbt.Node l c k v r)) = Suc (card (rbt_set l \<union> rbt_set r))"
    by (auto intro: card_insert_disjoint)
  also have "card (rbt_set l \<union> rbt_set r) = card (rbt_set l) + card (rbt_set r)"
    apply(rule card_Un_disjoint) by auto
  finally show ?thesis using r by (auto simp: rbt_set_keys_of)
qed

lemma card_keysof_size: "RBTree.rbt_sorted t \<Longrightarrow> card (keys_of (rbt_map t)) = size t"
  apply(induct t)
  subgoal apply (auto simp: rbt_map_def keys_of_def empty_map_def) done
  subgoal apply (auto simp: rbt_map_card) done
  done

definition sizeM1 :: "('a, 'b) Mapping_Str.map \<Rightarrow> nat" where "sizeM1 M = 1 + card (keys_of M)"

section \<open>Runtime in terms of size of the map\<close>

definition rbt_absch :: "nat \<Rightarrow> nat"  where "rbt_absch n = (nat (ceiling (2 * log 2 n + 1)))"

lemma rbt_absch_bound[asym_bound]: "(\<lambda>x. rbt_absch x) \<in> \<Theta>(\<lambda>n. ln n)"
  unfolding rbt_absch_def apply(rule ceiling_Theta)
unfolding eventually_nonneg_def eventually_sequentially apply(rule exI[where x=1])
  unfolding log_def by auto

lemma rbt_absch_mono: "x > 0 \<Longrightarrow> x \<le> y \<Longrightarrow> rbt_absch x \<le> rbt_absch y"
  by (auto simp: rbt_absch_def intro!: ceiling_mono nat_mono)

lemma "is_rbt t \<Longrightarrow> size1 t \<le> n \<Longrightarrow> rbt_absch (size1 t) \<le> rbt_absch n"
  apply(rule rbt_absch_mono) by(auto simp: size1_def)

subsection \<open>insert\<close>

lemma rbt_insert_time_mono: "x \<le> y \<Longrightarrow> rbt_insert_time x \<le> rbt_insert_time y"
  unfolding rbt_insert_time_def rbt_ins_time_def by auto

definition rbt_insert_logN :: "nat \<Rightarrow> nat" where "rbt_insert_logN n = rbt_insert_time (rbt_absch n)"

lemma rbt_insert_logN_gt0[resolve]: "rbt_insert_logN n > 0"
  by (simp add: rbt_insert_logN_def rbt_absch_def rbt_insert_time_def)

lemma rbt_insert_logN_mono: "0 < x \<Longrightarrow> x\<le>y \<Longrightarrow> rbt_insert_logN x \<le> rbt_insert_logN y"
  by(auto simp: rbt_insert_logN_def intro!: rbt_insert_time_mono rbt_absch_mono)

lemma rbt_insert_time_absch: assumes "is_rbt t" "rbt_sorted t" "rbt_map t = M" shows K[backward]: "rbt_insert_time (max_depth t) \<le> rbt_insert_logN (sizeM1 M)"
  unfolding rbt_insert_logN_def
proof (rule rbt_insert_time_mono)
  have A: "rbt_absch (size1 t) = rbt_absch (sizeM1 M)"
    using card_keysof_size[OF assms(2)] assms(3) by(auto simp: size1_def sizeM1_def)
  have B: "max_depth t \<le> rbt_absch (size1 t)"
    unfolding rbt_absch_def
      using assms(1) apply(auto dest!: rbt_height_le )
      by linarith
  from A B show "max_depth t \<le> rbt_absch (sizeM1 M)" by auto
qed

lemma rbt_insert_rule' [hoare_triple]:
  "is_rbt t \<Longrightarrow> rbt_sorted t \<Longrightarrow> M = rbt_map t \<Longrightarrow>
    <btree t p * $(rbt_insert_logN (sizeM1 M))>
   rbt_insert k v p
   <\<lambda>r. btree (RBTree.rbt_insert k v t) r * \<up>(is_rbt (RBTree.rbt_insert k v t))
         * \<up>(rbt_sorted (RBTree.rbt_insert k v t))
         * \<up>((M {k \<rightarrow> v}) = rbt_map (RBTree.rbt_insert k v t)) >\<^sub>t"
@proof
  @have  " rbt_insert_logN (sizeM1 M) \<ge>\<^sub>t rbt_insert_time (max_depth t)"
@qed

subsection \<open>search\<close>

definition rbt_search_time_logN :: "nat \<Rightarrow> nat" where "rbt_search_time_logN n = rbt_search_time (rbt_absch n)"

lemma rbt_search_time_logN_gt0[resolve]: "rbt_search_time_logN n > 0"
  by (simp add: rbt_search_time_logN_def rbt_absch_def rbt_search_time_def)

lemma rbt_search_time_mono: "x \<le> y \<Longrightarrow> rbt_search_time x \<le> rbt_search_time y"
  unfolding rbt_search_time_def by auto

lemma rbt_search_time_logN_mono: "0 < x \<Longrightarrow> x \<le> y \<Longrightarrow> rbt_search_time_logN x \<le> rbt_search_time_logN y"
  by(auto simp: rbt_search_time_logN_def intro!: rbt_absch_mono rbt_search_time_mono)

lemma assumes "is_rbt t" "rbt_sorted t" "rbt_map t = M" shows L[backward]: "rbt_search_time (max_depth t) \<le> rbt_search_time_logN (sizeM1 M)"
  unfolding rbt_search_time_logN_def
proof (rule rbt_search_time_mono)
  have A: "rbt_absch (size1 t) = rbt_absch (sizeM1 M)"
    using card_keysof_size[OF assms(2)] assms(3) by(auto simp: size1_def sizeM1_def)
  have B: "max_depth t \<le> rbt_absch (size1 t)"
    unfolding rbt_absch_def
      using assms(1) apply(auto dest!: rbt_height_le  )
      by linarith
  from A B show "max_depth t \<le> rbt_absch (sizeM1 M)" by auto
qed

lemma rbt_search_rule' [hoare_triple]:
  "is_rbt t \<Longrightarrow> rbt_sorted t \<Longrightarrow> M = rbt_map t \<Longrightarrow>
    <btree t p * $(rbt_search_time_logN (sizeM1 M))>
   rbt_search k p
   <\<lambda>r. btree t p * \<up>(r = RBTree.rbt_search t k)>\<^sub>t"
@proof
  @have  " rbt_search_time_logN (sizeM1 M) \<ge>\<^sub>t rbt_search_time (max_depth t)"
@qed

subsection \<open>delete\<close>

definition rbt_delete_time_logN :: "nat \<Rightarrow> nat" where "rbt_delete_time_logN n = rbt_delete_time (rbt_absch n)"

lemma rbt_delete_time_logN_gt0[resolve]: "rbt_delete_time_logN n > 0"
  by (simp add: rbt_delete_time_logN_def rbt_absch_def rbt_delete_time_def)

lemma rbt_delete_time_mono: "x \<le> y \<Longrightarrow> rbt_delete_time x \<le> rbt_delete_time y"
  unfolding rbt_delete_time_def btree_del_time_def by auto

lemma rbt_delete_time_logN_mono: "0 < x \<Longrightarrow> x \<le> y \<Longrightarrow> rbt_delete_time_logN x \<le> rbt_delete_time_logN y"
  by(auto simp: rbt_delete_time_logN_def intro!: rbt_absch_mono rbt_delete_time_mono)

lemma assumes "is_rbt t" "rbt_sorted t" "rbt_map t = M" shows rbt_delete_time_absch[backward]: "rbt_delete_time (max_depth t) \<le> rbt_delete_time_logN (sizeM1 M)"
  unfolding rbt_delete_time_logN_def
proof (rule rbt_delete_time_mono)
  have A: "rbt_absch (size1 t) = rbt_absch (sizeM1 M)"
    using card_keysof_size[OF assms(2)] assms(3) by(auto simp: size1_def sizeM1_def)
  have B: "max_depth t \<le> rbt_absch (size1 t)"
    unfolding rbt_absch_def
      using assms(1) apply(auto dest!: rbt_height_le  )
      by linarith
  from A B show "max_depth t \<le> rbt_absch (sizeM1 M)" by auto
qed

lemma rbt_delete_rule' [hoare_triple]:
  "is_rbt t \<Longrightarrow> rbt_sorted t \<Longrightarrow> M = rbt_map t \<Longrightarrow>
    <btree t p * $(rbt_delete_time_logN (sizeM1 M))>
   rbt_delete k p
   <\<lambda>p. btree (RBTree.delete k t) p * \<up>(is_rbt (RBTree.delete k t))
       * \<up>(rbt_sorted (RBTree.delete k t)) * \<up>((delete_map k M) = rbt_map (RBTree.delete k t))>\<^sub>t"
@proof
  @have  " rbt_delete_time_logN (sizeM1 M) \<ge>\<^sub>t rbt_delete_time (max_depth t)"
@qed

section \<open>Outer interface\<close>

definition rbt_map_assn :: "('a, 'b) map \<Rightarrow> ('a::{heap,linorder}, 'b::heap) rbt_node ref option \<Rightarrow> assn" where
  "rbt_map_assn M p = (\<exists>\<^sub>At. btree t p * \<up>(is_rbt t) * \<up>(rbt_sorted t) * \<up>(M = rbt_map t))"
setup \<open>add_rewrite_ent_rule @{thm rbt_map_assn_def}\<close>

subsection \<open>tree empty\<close>

subsection \<open>insert\<close>

theorem rbt_insert_rule [hoare_triple]:
  "<rbt_map_assn M b * $(rbt_insert_logN (sizeM1 M))> rbt_insert k v b <rbt_map_assn (M {k \<rightarrow> v})>\<^sub>t"
by auto2

lemma rbt_insert_logN_bound[asym_bound]:
  "(\<lambda>n. rbt_insert_logN n) \<in> \<Theta>(\<lambda>n. ln n)"
  unfolding rbt_insert_logN_def rbt_insert_time_def rbt_ins_time_def
  by auto2

subsection \<open>search\<close>

lemma rbt_search_time_logN_bound[asym_bound]:
  "(\<lambda>n. rbt_search_time_logN n) \<in> \<Theta>(\<lambda>n. ln n)" unfolding rbt_search_time_logN_def rbt_search_time_def by auto2

theorem rbt_search [hoare_triple]:
  "<rbt_map_assn M b * $(rbt_search_time_logN (sizeM1 M))> rbt_search x b <\<lambda>r. rbt_map_assn M b * \<up>(r = M\<langle>x\<rangle>)>\<^sub>t"
  by auto2

subsection \<open>delete\<close>

lemma rbt_delete_time_logN_bound[asym_bound]:
  "(\<lambda>n. rbt_delete_time_logN n) \<in> \<Theta>(\<lambda>n. ln n)" unfolding rbt_delete_time_logN_def rbt_delete_time_def btree_del_time_def by auto2

theorem rbt_delete_rule [hoare_triple]:
  "<rbt_map_assn M b * $(rbt_delete_time_logN (sizeM1 M))> rbt_delete k b <rbt_map_assn (delete_map k M)>\<^sub>t" by auto2

end


theory Partially_Filled_Array
  imports
    "Refine_Imperative_HOL.IICF_Array_List"
    Array_SBlit
begin

section "Partially Filled Arrays"

text \<open>An array that is only partially filled.
The number of actual elements contained is kept in a second element.
This represents a weakened version of the array\_list from IICF.\<close>

type_synonym 'a pfarray = "'a array_list"

subsection "Operations on Partly Filled Arrays"

definition is_pfa where
  "is_pfa c l \<equiv> \<lambda>(a,n). \<exists>\<^sub>A l'. a \<mapsto>\<^sub>a l' *  \<up>(c = length l' \<and> n \<le> c \<and> l = (take n l'))"

abbreviation "len :: 'a pfarray \<Rightarrow> nat \<equiv> snd"
abbreviation "arr :: 'a pfarray \<Rightarrow> 'a array \<equiv> fst"

lemma is_pfa_prec[safe_constraint_rules]: "precise (is_pfa c)"
  unfolding is_pfa_def[abs_def]
  apply(rule preciseI)
  apply(simp split: prod.splits)
  using preciseD snga_prec by fastforce

definition pfa_init where
  "pfa_init cap v n \<equiv> do {
  a \<leftarrow> Array.new cap v;
  return (a,n)
}"

lemma pfa_init_rule[sep_heap_rules]: "n \<le> N \<Longrightarrow> < emp > pfa_init N x n <is_pfa N (replicate n x)>"
  by (sep_auto simp: pfa_init_def is_pfa_def)

definition pfa_empty where
  "pfa_empty cap \<equiv> pfa_init cap default 0"

lemma pfa_empty_rule[sep_heap_rules]: "< emp > pfa_empty N <is_pfa N []>"
  by (sep_auto simp: pfa_empty_def is_pfa_def)

definition "pfa_length \<equiv> arl_length"

lemma pfa_length_rule[sep_heap_rules]: "
  <is_pfa c l a>
    pfa_length a
  <\<lambda>r. is_pfa c l a * \<up>(r=length l)>"
  by (sep_auto simp: pfa_length_def arl_length_def is_pfa_def)

definition "pfa_capacity \<equiv> \<lambda>(a,n). Array.len a
"

lemma pfa_capacity_rule[sep_heap_rules]: "
  <is_pfa c l a>
    pfa_capacity a
  <\<lambda>r. is_pfa c l a * \<up>(c=r)>"
  by (sep_auto simp: pfa_capacity_def arl_length_def is_pfa_def)

definition "pfa_is_empty \<equiv> arl_is_empty"

lemma pfa_is_empty_rule[sep_heap_rules]: "
  <is_pfa c l a>
    pfa_is_empty a
  <\<lambda>r. is_pfa c l a * \<up>(r\<longleftrightarrow>(l=[]))>"
  by (sep_auto simp: pfa_is_empty_def arl_is_empty_def is_pfa_def)

definition "pfa_append \<equiv> \<lambda>(a,n) x. do {
  Array.upd n x a;
  return (a,n+1)
}"

lemma pfa_append_rule[sep_heap_rules]:
   "len a < c  \<Longrightarrow>
    <is_pfa c l a>
      pfa_append a x
    <\<lambda>(a',n'). is_pfa c (l@[x]) (a',n') * \<up>(a' = arr a \<and> n' = (len a)+1) >"
  by (sep_auto
      simp: pfa_append_def arl_append_def is_pfa_def take_update_last neq_Nil_conv
      split: prod.splits nat.split)

definition "pfa_last \<equiv> arl_last"

lemma pfa_last_rule[sep_heap_rules]: "
  l\<noteq>[] \<Longrightarrow>
  <is_pfa c l a>
    pfa_last a
  <\<lambda>r. is_pfa c l a * \<up>(r=last l)>"
  by (sep_auto simp: pfa_last_def arl_last_def is_pfa_def last_take_nth_conv)

definition pfa_butlast :: "'a::heap pfarray \<Rightarrow> 'a pfarray Heap" where
  "pfa_butlast \<equiv> \<lambda>(a,n).
    return (a,n-1)
  "

lemma pfa_butlast_rule[sep_heap_rules]: "
  <is_pfa c l a>
    pfa_butlast a
  <\<lambda>(a',n'). is_pfa c (butlast l) (a',n') * \<up>(a' = arr a)>"
  by (sep_auto
      split: prod.splits
      simp: pfa_butlast_def is_pfa_def butlast_take)

definition "pfa_get \<equiv> arl_get"

lemma pfa_get_rule[sep_heap_rules]: "
  i < length l \<Longrightarrow>
  < is_pfa c l a>
    pfa_get a i
  <\<lambda>r. is_pfa c l a * \<up>((l!i) = r)>"
  by (sep_auto simp: is_pfa_def pfa_get_def arl_get_def  split: prod.split)

definition "pfa_set \<equiv> arl_set"

lemma pfa_set_rule[sep_heap_rules]: "
    i<length l \<Longrightarrow>
    <is_pfa c l a>
      pfa_set a i x
    <\<lambda>a'. is_pfa c (l[i:=x]) a' * \<up>(a' = a)>"
  by (sep_auto simp: pfa_set_def arl_set_def is_pfa_def split: prod.split)

definition pfa_shrink :: "nat \<Rightarrow> 'a::heap pfarray \<Rightarrow> 'a pfarray Heap" where
  "pfa_shrink k \<equiv> \<lambda>(a,n).
  return (a,k)
"

lemma pfa_shrink_rule[sep_heap_rules]: "
   k \<le> length xs \<Longrightarrow>
    < is_pfa c xs a >
      pfa_shrink k a
    <\<lambda>(a',n'). is_pfa c (take k xs) (a',n') * \<up>(n' = k \<and> a'=arr a) >"
  by (sep_auto
      simp: pfa_shrink_def is_pfa_def min.absorb1
      split: prod.splits nat.split)

definition pfa_shrink_cap :: "nat \<Rightarrow> 'a::heap pfarray \<Rightarrow> 'a pfarray Heap" where
  "pfa_shrink_cap k \<equiv> \<lambda>(a,n). do {
  a' \<leftarrow> array_shrink a k;
  return (a',min k n)
}
"

lemma pfa_shrink_cap_rule_preserve[sep_heap_rules]: "
   \<lbrakk>len a \<le> k; k \<le> c\<rbrakk> \<Longrightarrow>
    < is_pfa c l a >
      pfa_shrink_cap k a
    <\<lambda>a'. is_pfa k l a' >\<^sub>t"
  by (sep_auto
      simp: pfa_shrink_cap_def is_pfa_def min.absorb1 min.absorb2
      split: prod.splits nat.split)

lemma pfa_shrink_cap_rule: "
   \<lbrakk>k \<le> c\<rbrakk> \<Longrightarrow>
    < is_pfa c l a >
      pfa_shrink_cap k a
    <\<lambda>a'. is_pfa k (take k l) a' >\<^sub>t"
  by (sep_auto
      simp: pfa_shrink_cap_def is_pfa_def min.absorb1 min.absorb2
      split: prod.splits nat.split dest: mod_starD)

definition "array_ensure a s x \<equiv> do {
    l\<leftarrow>Array.len a;
    if l\<ge>s then
      return a
    else do {
      a'\<leftarrow>Array.new s x;
      blit a 0 a' 0 l;
      return a'
    }
  }"

lemma array_ensure_rule[sep_heap_rules]:
  shows "
      < a\<mapsto>\<^sub>ala >
        array_ensure a s x
      <\<lambda>a'. a'\<mapsto>\<^sub>a (la @ replicate (s-length la) x)>\<^sub>t"
  unfolding array_ensure_def
  by sep_auto

(* Ensure a certain capacity *)
definition pfa_ensure :: "'a::{heap,default} pfarray \<Rightarrow> nat \<Rightarrow> 'a pfarray Heap" where
  "pfa_ensure \<equiv> \<lambda>(a,n) k. do {
  a' \<leftarrow> array_ensure a k default;
  return (a',n)
}
"

lemma pfa_ensure_rule[sep_heap_rules]: "
    < is_pfa c l a >
      pfa_ensure a k
    <\<lambda>(a',n'). is_pfa (max c k) l (a',n') * \<up>(n' = len a \<and> c \<ge> len a)>\<^sub>t"
  by (sep_auto
      simp: pfa_ensure_def is_pfa_def split!: prod.splits)

definition "pfa_copy \<equiv> arl_copy"

lemma pfa_copy_rule[sep_heap_rules]:
  "< is_pfa c l a >
   pfa_copy a
   <\<lambda>r. is_pfa c l a * is_pfa c l r>\<^sub>t"
  by (sep_auto simp: pfa_copy_def arl_copy_def is_pfa_def)

definition pfa_blit :: "'a::heap pfarray \<Rightarrow> nat \<Rightarrow> 'a::heap pfarray \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> unit Heap" where
  "pfa_blit \<equiv> \<lambda>(src,sn) si (dst,dn) di l. blit src si dst di l"

lemma min_nat: "min a (a+b) = (a::nat)"
  by auto

lemma pfa_blit_rule[sep_heap_rules]:
  assumes LEN: "si+l \<le> sn" "di \<le> dn" "di+l \<le> dc"
  shows
    "< is_pfa sc src (srci,sn)
      * is_pfa dc dst (dsti,dn) >
    pfa_blit (srci,sn) si (dsti,dn) di l
    <\<lambda>_. is_pfa sc src (srci,sn)
      * is_pfa dc (take di dst @ take l (drop si src) @ drop (di+l) dst) (dsti,max (di+l) dn)
    >"
  using LEN apply(sep_auto simp add: min_nat is_pfa_def pfa_blit_def min.commute min.absorb1 heap: blit_rule)
   apply (simp add: min.absorb1 take_drop)
  apply (simp add: drop_take max_def)
  done

definition pfa_drop :: "('a::heap) pfarray \<Rightarrow> nat \<Rightarrow> 'a pfarray \<Rightarrow> 'a pfarray Heap" where
  "pfa_drop \<equiv> \<lambda>(src,sn) si (dst,dn). do {
   blit src si dst 0 (sn-si);
   return (dst,(sn-si))
}
"

lemma pfa_drop_rule_pair[sep_heap_rules]:
  assumes LEN: "k \<le> sn" "(sn-k) \<le> dc"
  shows
    "< is_pfa sc src (srci,sn)
      * is_pfa dc dst (dsti,dn) >
    pfa_drop (srci,sn) k (dsti,dn)
    <\<lambda>(dsti',dn'). is_pfa sc src (srci,sn)
      * is_pfa dc (drop k src) (dsti',dn')
      * \<up>(dsti' = dsti)
    >"
  using LEN apply (sep_auto simp add: drop_take is_pfa_def pfa_drop_def dest!: mod_starD heap: pfa_blit_rule)
  done

lemma pfa_drop_rule[sep_heap_rules]:
  assumes LEN: "k \<le> len srci" "(len srci-k) \<le> dc"
  shows
    "< is_pfa sc src srci
      * is_pfa dc dst dsti >
    pfa_drop srci k dsti
    <\<lambda>(dsti',dn'). is_pfa sc src srci
      * is_pfa dc (drop k src) (dsti',dn')
      * \<up>(dsti' = arr dsti)
    >"
  using LEN apply (sep_auto simp add: drop_take is_pfa_def pfa_drop_def dest!: mod_starD heap: pfa_blit_rule split!: prod.splits)
  done

definition "pfa_append_grow \<equiv> \<lambda>(a,n) x. do {
  l \<leftarrow> pfa_capacity (a,n);
  a' \<leftarrow> if l = n
  then array_grow a (l+1) x
  else Array.upd n x a;
  return (a',n+1)
}"

lemma pfa_append_grow_full_rule[sep_heap_rules]: "n = c \<Longrightarrow>
     <is_pfa c l (a,n)>
  array_grow a (c+1) x
      <\<lambda>a'. is_pfa (c+1) (l@[x]) (a',n+1)>\<^sub>t"
  apply(sep_auto simp add: is_pfa_def
      heap del: array_grow_rule)
  apply(vcg heap del: array_grow_rule heap add: array_grow_rule[of l "(Suc (length l))" a x])
   apply simp
  apply(rule ent_ex_postI[where ?x="l@[x]"])
  apply sep_auto
  done

lemma pfa_append_grow_less_rule: "n < c \<Longrightarrow>
 <is_pfa c l (a,n)>
    Array.upd n x a
<\<lambda>a'. is_pfa c (l@[x]) (a',n+1)>\<^sub>t"
  apply(sep_auto simp add: is_pfa_def take_update_last)
  done

lemma pfa_append_grow_rule[sep_heap_rules]: "
  <is_pfa c l (a,n)>
  pfa_append_grow (a,n) x
  <\<lambda>(a',n'). is_pfa (if c = n then c+1 else c) (l@[x]) (a',n') * \<up>(n'=n+1 \<and> c \<ge> n)>\<^sub>t"
  apply(subst pfa_append_grow_def)
  apply(rule hoare_triple_preI)
  apply (sep_auto
      heap add: pfa_append_grow_full_rule pfa_append_grow_less_rule)
   apply(sep_auto simp add: is_pfa_def)
  apply(sep_auto simp add: is_pfa_def)
  done

(* This definition has only one access to the array length *)
definition "pfa_append_grow' \<equiv> \<lambda>(a,n) x. do {
  a' \<leftarrow> pfa_ensure (a,n) (n+1);
  a'' \<leftarrow> pfa_append a' x;
  return a''
}"

lemma pfa_append_grow'_rule[sep_heap_rules]: "
  <is_pfa c l (a,n)>
  pfa_append_grow' (a,n) x
  <\<lambda>(a',n'). is_pfa (max (n+1) c) (l@[x]) (a',n') * \<up>(n'=n+1 \<and> c \<ge> n)>\<^sub>t"
  unfolding pfa_append_grow'_def
  by (sep_auto simp add: max_def)

definition "pfa_insert \<equiv> \<lambda>(a,n) i x. do {
  a' \<leftarrow> array_shr a i 1;
  a'' \<leftarrow> Array.upd i x a;
  return (a'',n+1)
}"

lemma list_update_last: "length ls = Suc i \<Longrightarrow> ls[i:=x] = (take i ls)@[x]"
  by (metis append_eq_conv_conj length_Suc_rev_conv list_update_length)

lemma pfa_insert_rule[sep_heap_rules]:
  "\<lbrakk>i \<le> n; n < c\<rbrakk> \<Longrightarrow>
  <is_pfa c l (a,n)>
  pfa_insert (a,n) i x
  <\<lambda>(a',n'). is_pfa c (take i l@x#drop i l) (a',n') * \<up>(n' = n+1 \<and> a=a')>"
  unfolding pfa_insert_def is_pfa_def
  by (sep_auto simp add: list_update_append1 list_update_last
      Suc_diff_le drop_take min_def)

definition pfa_insert_grow ::  "'a::{heap,default} pfarray \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a pfarray Heap"
  where "pfa_insert_grow \<equiv> \<lambda>(a,n) i x. do {
  a' \<leftarrow> pfa_ensure (a,n) (n+1);
  a'' \<leftarrow> pfa_insert a' i x;
  return a''
}"

lemma pfa_insert_grow_rule[sep_heap_rules]:
  "i \<le> n \<Longrightarrow>
  <is_pfa c l (a,n)>
  pfa_insert_grow (a,n) i x
  <\<lambda>(a',n'). is_pfa (max c (n+1)) (take i l@x#drop i l) (a',n') * \<up>(n'=n+1 \<and> c \<ge> n)>\<^sub>t"
  unfolding pfa_insert_grow_def
  by (sep_auto heap add: pfa_insert_rule[of i n "max c (Suc n)"])

definition pfa_extend where
  "pfa_extend \<equiv> \<lambda> (a,n) (b,m). do{
  blit b 0 a n m;
  return (a,n+m)
}"

lemma pfa_extend_rule[sep_heap_rules]:
  "n+m \<le> c \<Longrightarrow>
  <is_pfa c l1 (a,n) * is_pfa d l2 (b,m)>
  pfa_extend (a,n) (b,m)
  <\<lambda>(a',n'). is_pfa c (l1@l2) (a',n') * \<up>(a' = a \<and> n'=n+m) * is_pfa d l2 (b,m)>\<^sub>t"
  unfolding pfa_extend_def
  by (sep_auto simp add: is_pfa_def min.absorb1 min.absorb2 heap add: blit_rule)

definition pfa_extend_grow where
  "pfa_extend_grow \<equiv> \<lambda> (a,n) (b,m). do{
  a' \<leftarrow> array_ensure a (n+m) default;
  blit b 0 a' n m;
  return (a',n+m)
}"

lemma pfa_extend_grow_rule[sep_heap_rules]:
  "<is_pfa c l1 (a,n) * is_pfa d l2 (b,m)>
  pfa_extend_grow (a,n) (b,m)
  <\<lambda>(a',n'). is_pfa (max c (n+m)) (l1@l2) (a',n') * \<up>(n'=n+m \<and> c \<ge> n) * is_pfa d l2 (b,m)>\<^sub>t"
  unfolding pfa_extend_grow_def
  by (sep_auto simp add: is_pfa_def min.absorb1 min.absorb2 heap add: blit_rule)

definition pfa_append_extend_grow where
  "pfa_append_extend_grow \<equiv> \<lambda> (a,n) x (b,m). do{
  a' \<leftarrow> array_ensure a (n+m+1) default;
  a'' \<leftarrow> Array.upd n x a';
  blit b 0 a'' (n+1) m;
  return (a'',n+m+1)
}"

lemma pfa_append_extend_grow_rule[sep_heap_rules]:
  "<is_pfa c l1 (a,n) * is_pfa d l2 (b,m)>
  pfa_append_extend_grow (a,n) x (b,m)
  <\<lambda>(a',n'). is_pfa (max c (n+m+1)) (l1@x#l2) (a',n') * \<up>(n'=n+m+1 \<and> c \<ge> n) * is_pfa d l2 (b,m)>\<^sub>t"
  unfolding pfa_append_extend_grow_def
  by (sep_auto simp add: list_update_last is_pfa_def min.absorb1 min.absorb2 heap add: blit_rule)

definition "pfa_delete \<equiv> \<lambda>(a,n) i. do {
  array_shl a (i+1) 1;
  return (a,n-1)
}"

lemma pfa_delete_rule[sep_heap_rules]:
  "i < n \<Longrightarrow>
  <is_pfa c l (a,n)>
  pfa_delete (a,n) i
  <\<lambda>(a',n'). is_pfa c (take i l@drop (i+1) l) (a',n') * \<up>(n' = n-1 \<and> a=a')>"
  unfolding pfa_delete_def is_pfa_def
  apply (sep_auto simp add: drop_take min_def)
  by (metis Suc_diff_Suc diff_zero dual_order.strict_trans2 le_less_Suc_eq zero_le)

end


(*
 * Copyright 2019, NTU
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 *  Author: Albert Rizaldi, NTU Singapore
 *)

theory Unsigned_Add_Trans_Typed
  imports VHDL_Hoare_Typed Bits_Int_Aux
begin

datatype sig = A | B | C

definition add :: "sig conc_stmt" where
  "add \<equiv> process {A, B} : Bassign_trans C (Badd (Bsig A) (Bsig B)) 1"

locale unsigned_addition =
  fixes \<Gamma> :: "sig tyenv"
  fixes len len1 len2 :: nat
  assumes len_def: "len = max len1 len2"
  assumes atype: "\<Gamma> A = Lty Uns len1" and btype: "\<Gamma> B = Lty Uns len2" and ctype: "\<Gamma> C = Lty Uns len"
  assumes len1: "0 < len1" and len2: "0 < len2"
begin

lemma well_typed:
  "seq_wt \<Gamma> (Bassign_trans C (Badd (Bsig A) (Bsig B)) 1)"
  by (metis atype bexp_wt.intros(15) bexp_wt.intros(3) btype ctype len1 len2 len_def seq_wt.intros(4))

abbreviation "lof_wline tw sig n \<equiv> lval_of (wline_of tw sig n)"

text \<open>Here we factor out common expression in both inv1 and inv2. It is parametrised by the index
we are interested with for C (first argument) and A (the second argument). Note that the index
we are interested with for A should be the same as the index for B.\<close>

definition inv :: "sig assn2" where
  "inv tw \<equiv> (lof_wline tw C (fst tw) = bin_to_bl len (bl_to_bin (lof_wline tw A (fst tw - 1)) + bl_to_bin (lof_wline tw B (fst tw - 1))))"

definition inv2 :: "sig assn2" where
  "inv2 tw \<equiv> (disjnt {A, B} (event_of tw) \<longrightarrow> (\<forall>i > fst tw. lof_wline tw C i = lof_wline tw C (fst tw)))"

abbreviation "next_world tw \<equiv> (next_time_world tw, snd tw)"

lemma inv_next_time:
  fixes tw
  defines "v \<equiv> eval_world_raw2 tw (Badd (Bsig A) (Bsig B))"
  defines "tw' \<equiv> tw[C, 1 :=\<^sub>2 v]"
  assumes "wityping \<Gamma> (snd tw)"
  shows   "inv (fst tw' + 1, snd tw')"
proof -
  have bexpA: "bexp_wt \<Gamma> (Bsig A) (Lty Uns len1)" and bexpB: "bexp_wt \<Gamma> (Bsig B) (Lty Uns len2)"
    using unsigned_addition_axioms unfolding unsigned_addition_def by (metis bexp_wt.intros(3))+
  obtain bsA bsB where evalA: "eval_world_raw (fst tw) (snd tw) (Bsig A) = Lv Uns bsA" and" length bsA = len1 " and
                       evalB: "eval_world_raw (fst tw) (snd tw) (Bsig B) = Lv Uns bsB" and" length bsB = len2 "
      using eval_world_raw_lv[OF bexpA `wityping \<Gamma> (snd tw)`] eval_world_raw_lv[OF bexpB `wityping \<Gamma> (snd tw)`] by blast
  have "lof_wline tw' C (fst tw + 1) = lval_of v"
    unfolding tw'_def worldline_upd2_def worldline_upd_def by auto
  also have "... = bin_to_bl len (bl_to_bin (lof_wline tw A (fst tw)) + bl_to_bin (lof_wline tw B (fst tw)))"
    using evalA evalB `length bsA = len1` `length bsB = len2`
    unfolding v_def eval_world_raw.simps eval_arith.simps len_def Let_def by auto
  finally show ?thesis
    unfolding inv_def tw'_def worldline_upd2_def worldline_upd_def  by auto
qed

lemma inv2_next_time:
  fixes tw v
  defines "tw' \<equiv> tw[C, 1 :=\<^sub>2 v]"
  shows   "inv2 (fst tw' + 1, snd tw')"
  unfolding inv2_def tw'_def worldline_upd2_def worldline_upd_def by auto

lemma add_conc_hoare:
  "\<And>tw. inv tw \<and> inv2 tw \<and> disjnt {A, B} (event_of tw) \<Longrightarrow> inv (fst tw + 1, snd tw)"
proof -
  fix tw
  assume "inv tw \<and> inv2 tw \<and> disjnt {A, B} (event_of tw)"
  hence "inv tw" and "inv2 tw" and "disjnt {A, B} (event_of tw)"
    by auto
  have "lof_wline tw C (fst tw + 1) = lof_wline tw C (fst tw)"
    using `inv2 tw` `disjnt {A, B} (event_of tw)` unfolding inv2_def by auto
  also have "... = bin_to_bl len (bl_to_bin (lval_of (wline_of tw A (get_time tw - 1))) + bl_to_bin (lval_of (wline_of tw B (get_time tw - 1))))"
    using `inv tw` unfolding inv_def by auto
  also have "... = bin_to_bl len (bl_to_bin (lval_of (wline_of tw A (fst tw))) + bl_to_bin (lval_of (wline_of tw B (fst tw))))"
    using `disjnt {A, B} (event_of tw)`  unfolding event_of_alt_def
    by (smt diff_0_eq_0 disjnt_insert1 mem_Collect_eq)
  finally show "inv (fst tw + 1, snd tw)"
    unfolding inv_def by auto
qed

lemma add_conc_hoare2:
  "\<And>tw. inv2 tw \<and> disjnt {A, B} (event_of tw) \<Longrightarrow> inv2 (fst tw + 1, snd tw)"
  unfolding inv2_def by auto

lemma conc_stmt_wf_add:
  "conc_stmt_wf add"
  unfolding add_def conc_stmt_wf_def by auto

lemma nonneg_delay_conc_add:
  "nonneg_delay_conc add"
  unfolding add_def by auto

lemma nonneg_delay_conc_add':
  "nonneg_delay_conc ( process {A, B} : Bassign_trans C (Badd (Bsig A) (Bsig B)) 1)"
  using nonneg_delay_conc_add unfolding add_def by auto

lemma conc_wt_add:
  "conc_wt \<Gamma> add"
  unfolding add_def  by (meson conc_wt.intros(1) well_typed)

lemma conc_wt_add':
  "conc_wt \<Gamma> ( process {A, B} : Bassign_trans C (Badd (Bsig A) (Bsig B)) 1)"
  using conc_wt_add unfolding add_def by auto

lemma add_conc_sim2':
  "\<Gamma> \<turnstile>\<^sub>s \<lbrace>\<lambda>tw. inv tw \<and> inv2 tw\<rbrace> add \<lbrace>\<lambda>tw. inv tw \<and> inv2 tw\<rbrace>"
  apply (rule While_Suc)
  apply (rule Conseq'[where P="wp3_conc \<Gamma> add (\<lambda>tw. inv  (fst tw + 1, snd tw) \<and>
                                                      inv2 (fst tw + 1, snd tw))", rotated])
  apply (rule wp3_conc_is_pre, rule conc_stmt_wf_add, rule nonneg_delay_conc_add, rule conc_wt_add, simp)
  unfolding add_def  wp3_conc_single'[OF conc_wt_add' nonneg_delay_conc_add'] wp3_fun.simps
  using inv_next_time inv2_next_time add_conc_hoare add_conc_hoare2 by presburger

text \<open>Initialisation preserves the invariant\<close>

lemma nonneg_delay_add:
  " nonneg_delay (Bassign_trans C (Badd (Bsig A) (Bsig B)) 1)"
  using nonneg_delay_conc_add' by auto

lemma init_sat_nand_inv_comb:
  "init_sim2_hoare_wt \<Gamma> (\<lambda>tw. fst tw = 0) add (\<lambda>tw. inv tw \<and> inv2 tw)"
  unfolding add_def
  apply (rule AssignI_suc, rule SingleI)
  apply (rule Conseq3[where Q="\<lambda>tw. inv (fst tw + 1, snd tw) \<and> inv2 (fst tw + 1, snd tw)", rotated])
  apply (rule wp3_fun_is_pre[OF well_typed nonneg_delay_add], simp)
  unfolding wp3_fun.simps using inv_next_time inv2_next_time by blast

lemma correctness:
  assumes "sim_fin2 w (i + 1) add tw'" and "wityping \<Gamma> w"
  shows "lof_wline tw' C (i + 1) = bin_to_bl len (bl_to_bin (lof_wline tw' A i) + bl_to_bin (lof_wline tw' B i))"
  using grand_correctness[OF assms conc_stmt_wf_add conc_wt_add nonneg_delay_conc_add add_conc_sim2' init_sat_nand_inv_comb]
  unfolding  inv_def by (metis (no_types, lifting) add_diff_cancel_right' assms(1)
  sim_fin2.cases world_maxtime_lt_fst_tres)
end

end


section\<open>Well-founded relation on names\<close>
theory FrecR
  imports
    Transitive_Models.Discipline_Function
    Edrel
begin

text\<open>\<^term>\<open>frecR\<close> is the well-founded relation on names that allows
us to define forcing for atomic formulas.\<close>

definition
  ftype :: "i\<Rightarrow>i" where
  "ftype \<equiv> fst"

definition
  name1 :: "i\<Rightarrow>i" where
  "name1(x) \<equiv> fst(snd(x))"

definition
  name2 :: "i\<Rightarrow>i" where
  "name2(x) \<equiv> fst(snd(snd(x)))"

definition
  cond_of :: "i\<Rightarrow>i" where
  "cond_of(x) \<equiv> snd(snd(snd((x))))"

lemma components_simp:
  "ftype(\<langle>f,n1,n2,c\<rangle>) = f"
  "name1(\<langle>f,n1,n2,c\<rangle>) = n1"
  "name2(\<langle>f,n1,n2,c\<rangle>) = n2"
  "cond_of(\<langle>f,n1,n2,c\<rangle>) = c"
  unfolding ftype_def name1_def name2_def cond_of_def
  by simp_all

definition eclose_n :: "[i\<Rightarrow>i,i] \<Rightarrow> i" where
  "eclose_n(name,x) = eclose({name(x)})"

definition
  ecloseN :: "i \<Rightarrow> i" where
  "ecloseN(x) = eclose_n(name1,x) \<union> eclose_n(name2,x)"

lemma components_in_eclose :
  "n1 \<in> ecloseN(\<langle>f,n1,n2,c\<rangle>)"
  "n2 \<in> ecloseN(\<langle>f,n1,n2,c\<rangle>)"
  unfolding ecloseN_def eclose_n_def
  using components_simp arg_into_eclose by auto

lemmas names_simp = components_simp(2) components_simp(3)

lemma ecloseNI1 :
  assumes "x \<in> eclose(n1) \<or> x\<in>eclose(n2)"
  shows "x \<in> ecloseN(\<langle>f,n1,n2,c\<rangle>)"
  unfolding ecloseN_def eclose_n_def
  using assms eclose_sing names_simp
  by auto

lemmas ecloseNI = ecloseNI1

lemma ecloseN_mono :
  assumes "u \<in> ecloseN(x)" "name1(x) \<in> ecloseN(y)" "name2(x) \<in> ecloseN(y)"
  shows "u \<in> ecloseN(y)"
proof -
  from \<open>u\<in>_\<close>
  consider (a) "u\<in>eclose({name1(x)})" | (b) "u \<in> eclose({name2(x)})"
    unfolding ecloseN_def  eclose_n_def by auto
  then
  show ?thesis
  proof cases
    case a
    with \<open>name1(x) \<in> _\<close>
    show ?thesis
      unfolding ecloseN_def  eclose_n_def
      using eclose_singE[OF a] mem_eclose_trans[of u "name1(x)" ] by auto
  next
    case b
    with \<open>name2(x) \<in> _\<close>
    show ?thesis
      unfolding ecloseN_def eclose_n_def
      using eclose_singE[OF b] mem_eclose_trans[of u "name2(x)"] by auto
  qed
qed

definition
  is_ftype :: "(i\<Rightarrow>o)\<Rightarrow>i\<Rightarrow>i\<Rightarrow>o" where
  "is_ftype \<equiv> is_fst"

definition
  ftype_fm :: "[i,i] \<Rightarrow> i" where
  "ftype_fm \<equiv> fst_fm"

lemma is_ftype_iff_sats [iff_sats]:
  assumes
    "nth(a,env) = x" "nth(b,env) = y" "a\<in>nat" "b\<in>nat" "env \<in> list(A)"
  shows
    "is_ftype(##A,x,y)  \<longleftrightarrow> sats(A,ftype_fm(a,b), env)"
  unfolding ftype_fm_def is_ftype_def
  using assms sats_fst_fm
  by simp

definition
  is_name1 :: "(i\<Rightarrow>o)\<Rightarrow>i\<Rightarrow>i\<Rightarrow>o" where
  "is_name1(M,x,t2) \<equiv> is_hcomp(M,is_fst(M),is_snd(M),x,t2)"

definition
  name1_fm :: "[i,i] \<Rightarrow> i" where
  "name1_fm(x,t) \<equiv> hcomp_fm(fst_fm,snd_fm,x,t)"

lemma sats_name1_fm [simp]:
  "\<lbrakk> x \<in> nat; y \<in> nat;env \<in> list(A) \<rbrakk> \<Longrightarrow>
    (A, env \<Turnstile> name1_fm(x,y)) \<longleftrightarrow> is_name1(##A, nth(x,env), nth(y,env))"
  unfolding name1_fm_def is_name1_def
  using sats_fst_fm sats_snd_fm sats_hcomp_fm[of A "is_fst(##A)" _ fst_fm "is_snd(##A)"]
  by simp

lemma is_name1_iff_sats [iff_sats]:
  assumes
    "nth(a,env) = x" "nth(b,env) = y" "a\<in>nat" "b\<in>nat" "env \<in> list(A)"
  shows
    "is_name1(##A,x,y)  \<longleftrightarrow> A , env \<Turnstile> name1_fm(a,b)"
  using assms sats_name1_fm
  by simp

definition
  is_snd_snd :: "(i\<Rightarrow>o)\<Rightarrow>i\<Rightarrow>i\<Rightarrow>o" where
  "is_snd_snd(M,x,t) \<equiv> is_hcomp(M,is_snd(M),is_snd(M),x,t)"

definition
  snd_snd_fm :: "[i,i]\<Rightarrow>i" where
  "snd_snd_fm(x,t) \<equiv> hcomp_fm(snd_fm,snd_fm,x,t)"

lemma sats_snd2_fm [simp]:
  "\<lbrakk> x \<in> nat; y \<in> nat;env \<in> list(A) \<rbrakk> \<Longrightarrow>
    (A, env  \<Turnstile> snd_snd_fm(x,y)) \<longleftrightarrow> is_snd_snd(##A, nth(x,env), nth(y,env))"
  unfolding snd_snd_fm_def is_snd_snd_def
  using sats_snd_fm sats_hcomp_fm[of A "is_snd(##A)" _ snd_fm "is_snd(##A)"]
  by simp

definition
  is_name2 :: "(i\<Rightarrow>o)\<Rightarrow>i\<Rightarrow>i\<Rightarrow>o" where
  "is_name2(M,x,t3) \<equiv> is_hcomp(M,is_fst(M),is_snd_snd(M),x,t3)"

definition
  name2_fm :: "[i,i] \<Rightarrow> i" where
  "name2_fm(x,t3) \<equiv> hcomp_fm(fst_fm,snd_snd_fm,x,t3)"

lemma sats_name2_fm :
  "\<lbrakk> x \<in> nat; y \<in> nat;env \<in> list(A) \<rbrakk>
    \<Longrightarrow> (A , env \<Turnstile> name2_fm(x,y)) \<longleftrightarrow> is_name2(##A, nth(x,env), nth(y,env))"
  unfolding name2_fm_def is_name2_def
  using sats_fst_fm sats_snd2_fm sats_hcomp_fm[of A "is_fst(##A)" _ fst_fm "is_snd_snd(##A)"]
  by simp

lemma is_name2_iff_sats [iff_sats]:
  assumes
    "nth(a,env) = x" "nth(b,env) = y" "a\<in>nat" "b\<in>nat" "env \<in> list(A)"
  shows
    "is_name2(##A,x,y)  \<longleftrightarrow> A, env \<Turnstile> name2_fm(a,b)"
  using assms sats_name2_fm
  by simp

definition
  is_cond_of :: "(i\<Rightarrow>o)\<Rightarrow>i\<Rightarrow>i\<Rightarrow>o" where
  "is_cond_of(M,x,t4) \<equiv> is_hcomp(M,is_snd(M),is_snd_snd(M),x,t4)"

definition
  cond_of_fm :: "[i,i] \<Rightarrow> i" where
  "cond_of_fm(x,t4) \<equiv> hcomp_fm(snd_fm,snd_snd_fm,x,t4)"

lemma sats_cond_of_fm :
  "\<lbrakk> x \<in> nat; y \<in> nat;env \<in> list(A) \<rbrakk> \<Longrightarrow>
    (A, env \<Turnstile> cond_of_fm(x,y)) \<longleftrightarrow> is_cond_of(##A, nth(x,env), nth(y,env))"
  unfolding cond_of_fm_def is_cond_of_def
  using sats_snd_fm sats_snd2_fm sats_hcomp_fm[of A "is_snd(##A)" _ snd_fm "is_snd_snd(##A)"]
  by simp

lemma is_cond_of_iff_sats [iff_sats]:
  assumes
    "nth(a,env) = x" "nth(b,env) = y" "a\<in>nat" "b\<in>nat" "env \<in> list(A)"
  shows
    "is_cond_of(##A,x,y) \<longleftrightarrow> A, env \<Turnstile> cond_of_fm(a,b)"
  using assms sats_cond_of_fm
  by simp

lemma components_type[TC] :
  assumes "a\<in>nat" "b\<in>nat"
  shows
    "ftype_fm(a,b)\<in>formula"
    "name1_fm(a,b)\<in>formula"
    "name2_fm(a,b)\<in>formula"
    "cond_of_fm(a,b)\<in>formula"
  using assms
  unfolding ftype_fm_def fst_fm_def snd_fm_def snd_snd_fm_def name1_fm_def name2_fm_def
    cond_of_fm_def hcomp_fm_def
  by simp_all

lemmas components_iff_sats = is_ftype_iff_sats is_name1_iff_sats is_name2_iff_sats
  is_cond_of_iff_sats

lemmas components_defs = ftype_fm_def snd_snd_fm_def hcomp_fm_def
  name1_fm_def name2_fm_def cond_of_fm_def

definition
  is_eclose_n :: "[i\<Rightarrow>o,[i\<Rightarrow>o,i,i]\<Rightarrow>o,i,i] \<Rightarrow> o" where
  "is_eclose_n(N,is_name,en,t) \<equiv>
        \<exists>n1[N].\<exists>s1[N]. is_name(N,t,n1) \<and> is_singleton(N,n1,s1) \<and> is_eclose(N,s1,en)"

definition
  eclose_n1_fm :: "[i,i] \<Rightarrow> i" where
  "eclose_n1_fm(m,t) \<equiv> Exists(Exists(And(And(name1_fm(t+\<^sub>\<omega>2,0),singleton_fm(0,1)),
                                       is_eclose_fm(1,m+\<^sub>\<omega>2))))"

definition
  eclose_n2_fm :: "[i,i] \<Rightarrow> i" where
  "eclose_n2_fm(m,t) \<equiv> Exists(Exists(And(And(name2_fm(t+\<^sub>\<omega>2,0),singleton_fm(0,1)),
                                       is_eclose_fm(1,m+\<^sub>\<omega>2))))"

definition
  is_ecloseN :: "[i\<Rightarrow>o,i,i] \<Rightarrow> o" where
  "is_ecloseN(N,t,en) \<equiv> \<exists>en1[N].\<exists>en2[N].
                is_eclose_n(N,is_name1,en1,t) \<and> is_eclose_n(N,is_name2,en2,t)\<and>
                union(N,en1,en2,en)"

definition
  ecloseN_fm :: "[i,i] \<Rightarrow> i" where
  "ecloseN_fm(en,t) \<equiv> Exists(Exists(And(eclose_n1_fm(1,t+\<^sub>\<omega>2),
                            And(eclose_n2_fm(0,t+\<^sub>\<omega>2),union_fm(1,0,en+\<^sub>\<omega>2)))))"

lemma ecloseN_fm_type [TC] :
  "\<lbrakk> en \<in> nat ; t \<in> nat \<rbrakk> \<Longrightarrow> ecloseN_fm(en,t) \<in> formula"
  unfolding ecloseN_fm_def eclose_n1_fm_def eclose_n2_fm_def by simp

lemma sats_ecloseN_fm [simp]:
  "\<lbrakk> en \<in> nat; t \<in> nat ; env \<in> list(A) \<rbrakk>
    \<Longrightarrow> (A, env \<Turnstile> ecloseN_fm(en,t)) \<longleftrightarrow> is_ecloseN(##A,nth(t,env),nth(en,env))"
  unfolding ecloseN_fm_def is_ecloseN_def eclose_n1_fm_def eclose_n2_fm_def is_eclose_n_def
  using nth_0 nth_ConsI sats_name1_fm sats_name2_fm singleton_iff_sats[symmetric]
  by auto

lemma is_ecloseN_iff_sats [iff_sats]:
  "\<lbrakk> nth(en, env) = ena; nth(t, env) = ta; en \<in> nat; t \<in> nat ; env \<in> list(A) \<rbrakk>
    \<Longrightarrow> is_ecloseN(##A,ta,ena) \<longleftrightarrow> A, env \<Turnstile> ecloseN_fm(en,t)"
  by simp

(* Relation of forces *)
definition
  frecR :: "i \<Rightarrow> i \<Rightarrow> o" where
  "frecR(x,y) \<equiv>
    (ftype(x) = 1 \<and> ftype(y) = 0
      \<and> (name1(x) \<in> domain(name1(y)) \<union> domain(name2(y)) \<and> (name2(x) = name1(y) \<or> name2(x) = name2(y))))
   \<or> (ftype(x) = 0 \<and> ftype(y) =  1 \<and> name1(x) = name1(y) \<and> name2(x) \<in> domain(name2(y)))"

lemma frecR_ftypeD :
  assumes "frecR(x,y)"
  shows "(ftype(x) = 0 \<and> ftype(y) = 1) \<or> (ftype(x) = 1 \<and> ftype(y) = 0)"
  using assms unfolding frecR_def by auto

lemma frecRI1: "s \<in> domain(n1) \<or> s \<in> domain(n2) \<Longrightarrow> frecR(\<langle>1, s, n1, q\<rangle>, \<langle>0, n1, n2, q'\<rangle>)"
  unfolding frecR_def by (simp add:components_simp)

lemma frecRI1': "s \<in> domain(n1) \<union> domain(n2) \<Longrightarrow> frecR(\<langle>1, s, n1, q\<rangle>, \<langle>0, n1, n2, q'\<rangle>)"
  unfolding frecR_def by (simp add:components_simp)

lemma frecRI2: "s \<in> domain(n1) \<or> s \<in> domain(n2) \<Longrightarrow> frecR(\<langle>1, s, n2, q\<rangle>, \<langle>0, n1, n2, q'\<rangle>)"
  unfolding frecR_def by (simp add:components_simp)

lemma frecRI2': "s \<in> domain(n1) \<union> domain(n2) \<Longrightarrow> frecR(\<langle>1, s, n2, q\<rangle>, \<langle>0, n1, n2, q'\<rangle>)"
  unfolding frecR_def by (simp add:components_simp)

lemma frecRI3: "\<langle>s, r\<rangle> \<in> n2 \<Longrightarrow> frecR(\<langle>0, n1, s, q\<rangle>, \<langle>1, n1, n2, q'\<rangle>)"
  unfolding frecR_def by (auto simp add:components_simp)

lemma frecRI3': "s \<in> domain(n2) \<Longrightarrow> frecR(\<langle>0, n1, s, q\<rangle>, \<langle>1, n1, n2, q'\<rangle>)"
  unfolding frecR_def by (auto simp add:components_simp)

lemma frecR_D1 :
  "frecR(x,y) \<Longrightarrow> ftype(y) = 0 \<Longrightarrow> ftype(x) = 1 \<and>
      (name1(x) \<in> domain(name1(y)) \<union> domain(name2(y)) \<and> (name2(x) = name1(y) \<or> name2(x) = name2(y)))"
  unfolding frecR_def
  by auto

lemma frecR_D2 :
  "frecR(x,y) \<Longrightarrow> ftype(y) = 1 \<Longrightarrow> ftype(x) = 0 \<and>
      ftype(x) = 0 \<and> ftype(y) =  1 \<and> name1(x) = name1(y) \<and> name2(x) \<in> domain(name2(y))"
  unfolding frecR_def
  by auto

lemma frecR_DI :
  assumes "frecR(\<langle>a,b,c,d\<rangle>,\<langle>ftype(y),name1(y),name2(y),cond_of(y)\<rangle>)"
  shows "frecR(\<langle>a,b,c,d\<rangle>,y)"
  using assms
  unfolding frecR_def
  by (force simp add:components_simp)

reldb_add "ftype" "is_ftype"
reldb_add "name1" "is_name1"
reldb_add "name2" "is_name2"

relativize "frecR" "is_frecR"

schematic_goal sats_frecR_fm_auto:
  assumes
    "i\<in>nat" "j\<in>nat" "env\<in>list(A)"
  shows
    "is_frecR(##A,nth(i,env),nth(j,env)) \<longleftrightarrow> A, env \<Turnstile> ?fr_fm(i,j)"
  unfolding is_frecR_def
  by (insert assms ; (rule sep_rules' cartprod_iff_sats components_iff_sats
        | simp del:sats_cartprod_fm)+)

synthesize "frecR" from_schematic sats_frecR_fm_auto

text\<open>Third item of Kunen's observations (p. 257) about the trcl relation.\<close>
lemma eq_ftypep_not_frecrR:
  assumes "ftype(x) = ftype(y)"
  shows "\<not> frecR(x,y)"
  using assms frecR_ftypeD by force

definition
  rank_names :: "i \<Rightarrow> i" where
  "rank_names(x) \<equiv> max(rank(name1(x)),rank(name2(x)))"

lemma rank_names_types [TC]:
  shows "Ord(rank_names(x))"
  unfolding rank_names_def max_def using Ord_rank Ord_Un by auto

definition
  mtype_form :: "i \<Rightarrow> i" where
  "mtype_form(x) \<equiv> if rank(name1(x)) < rank(name2(x)) then 0 else 2"

definition
  type_form :: "i \<Rightarrow> i" where
  "type_form(x) \<equiv> if ftype(x) = 0 then 1 else mtype_form(x)"

lemma type_form_tc [TC]:
  shows "type_form(x) \<in> 3"
  unfolding type_form_def mtype_form_def by auto

lemma frecR_le_rnk_names :
  assumes  "frecR(x,y)"
  shows "rank_names(x)\<le>rank_names(y)"
proof -
  obtain a b c d where
    H: "a = name1(x)" "b = name2(x)"
    "c = name1(y)" "d = name2(y)"
    "(a \<in> domain(c)\<union>domain(d) \<and> (b=c \<or> b = d)) \<or> (a = c \<and> b \<in> domain(d))"
    using assms
    unfolding frecR_def
    by force
  then
  consider
    (m) "a \<in> domain(c) \<and> (b = c \<or> b = d) "
    | (n) "a \<in> domain(d) \<and> (b = c \<or> b = d)"
    | (o) "b \<in> domain(d) \<and> a = c"
    by auto
  then
  show ?thesis
  proof(cases)
    case m
    then
    have "rank(a) < rank(c)"
      using eclose_rank_lt  in_dom_in_eclose
      by simp
    with \<open>rank(a) < rank(c)\<close> H m
    show ?thesis
      unfolding rank_names_def
      using Ord_rank max_cong max_cong2 leI
      by auto
  next
    case n
    then
    have "rank(a) < rank(d)"
      using eclose_rank_lt in_dom_in_eclose
      by simp
    with \<open>rank(a) < rank(d)\<close> H n
    show ?thesis
      unfolding rank_names_def
      using Ord_rank max_cong2 max_cong max_commutes[of "rank(c)" "rank(d)"] leI
      by auto
  next
    case o
    then
    have "rank(b) < rank(d)" (is "?b < ?d") "rank(a) = rank(c)" (is "?a = _")
      using eclose_rank_lt in_dom_in_eclose
      by simp_all
    with H
    show ?thesis
      unfolding rank_names_def
      using Ord_rank max_commutes max_cong2[OF leI[OF \<open>?b < ?d\<close>], of ?a]
      by simp
  qed
qed

definition
  \<Gamma> :: "i \<Rightarrow> i" where
  "\<Gamma>(x) = 3 ** rank_names(x) ++ type_form(x)"

lemma \<Gamma>_type [TC]:
  shows "Ord(\<Gamma>(x))"
  unfolding \<Gamma>_def by simp

lemma \<Gamma>_mono :
  assumes "frecR(x,y)"
  shows "\<Gamma>(x) < \<Gamma>(y)"
proof -
  have F: "type_form(x) < 3" "type_form(y) < 3"
    using ltI
    by simp_all
  from assms
  have A: "rank_names(x) \<le> rank_names(y)" (is "?x \<le> ?y")
    using frecR_le_rnk_names
    by simp
  then
  have "Ord(?y)"
    unfolding rank_names_def
    using Ord_rank max_def
    by simp
  note leE[OF \<open>?x\<le>?y\<close>]
  then
  show ?thesis
  proof(cases)
    case 1
    then
    show ?thesis
      unfolding \<Gamma>_def
      using oadd_lt_mono2 \<open>?x < ?y\<close> F
      by auto
  next
    case 2
    consider (a) "ftype(x) = 0 \<and> ftype(y) = 1" | (b) "ftype(x) = 1 \<and> ftype(y) = 0"
      using frecR_ftypeD[OF \<open>frecR(x,y)\<close>]
      by auto
    then show ?thesis
    proof(cases)
      case b
      moreover from this
      have "type_form(y) = 1"
        using type_form_def by simp
      moreover from calculation
      have "name2(x) = name1(y) \<or> name2(x) = name2(y) "  (is "?\<tau> = ?\<sigma>' \<or> ?\<tau> = ?\<tau>'")
        "name1(x) \<in> domain(name1(y)) \<union> domain(name2(y))" (is "?\<sigma> \<in> domain(?\<sigma>') \<union> domain(?\<tau>')")
        using assms unfolding type_form_def frecR_def by auto
      moreover from calculation
      have E: "rank(?\<tau>) = rank(?\<sigma>') \<or> rank(?\<tau>) = rank(?\<tau>')" by auto
      from calculation
      consider (c) "rank(?\<sigma>) < rank(?\<sigma>')" |  (d) "rank(?\<sigma>) < rank(?\<tau>')"
        using eclose_rank_lt in_dom_in_eclose by force
      then
      have "rank(?\<sigma>) < rank(?\<tau>)"
      proof (cases)
        case c
        with \<open>rank_names(x) = rank_names(y) \<close>
        show ?thesis
          unfolding rank_names_def mtype_form_def type_form_def
          using max_D2[OF E c] E assms Ord_rank
          by simp
      next
        case d
        with \<open>rank_names(x) = rank_names(y) \<close>
        show ?thesis
          unfolding rank_names_def mtype_form_def type_form_def
          using max_D2[OF _ d] max_commutes E assms Ord_rank disj_commute
          by simp
      qed
      with b
      have "type_form(x) = 0" unfolding type_form_def mtype_form_def by simp
      with \<open>rank_names(x) = rank_names(y) \<close> \<open>type_form(y) = 1\<close> \<open>type_form(x) = 0\<close>
      show ?thesis
        unfolding \<Gamma>_def by auto
    next
      case a
      then
      have "name1(x) = name1(y)" (is "?\<sigma> = ?\<sigma>'")
        "name2(x) \<in> domain(name2(y))" (is "?\<tau> \<in> domain(?\<tau>')")
        "type_form(x) = 1"
        using assms
        unfolding type_form_def frecR_def
        by auto
      then
      have "rank(?\<sigma>) = rank(?\<sigma>')" "rank(?\<tau>) < rank(?\<tau>')"
        using  eclose_rank_lt in_dom_in_eclose
        by simp_all
      with \<open>rank_names(x) = rank_names(y) \<close>
      have "rank(?\<tau>') \<le> rank(?\<sigma>')"
        using Ord_rank max_D1
        unfolding rank_names_def
        by simp
      with a
      have "type_form(y) = 2"
        unfolding type_form_def mtype_form_def
        using not_lt_iff_le assms
        by simp
      with \<open>rank_names(x) = rank_names(y) \<close> \<open>type_form(y) = 2\<close> \<open>type_form(x) = 1\<close>
      show ?thesis
        unfolding \<Gamma>_def by auto
    qed
  qed
qed

definition
  frecrel :: "i \<Rightarrow> i" where
  "frecrel(A) \<equiv> Rrel(frecR,A)"

lemma frecrelI :
  assumes "x \<in> A" "y\<in>A" "frecR(x,y)"
  shows "\<langle>x,y\<rangle>\<in>frecrel(A)"
  using assms unfolding frecrel_def Rrel_def by auto

lemma frecrelD :
  assumes "\<langle>x,y\<rangle> \<in> frecrel(A1\<times>A2\<times>A3\<times>A4)"
  shows
    "ftype(x) \<in> A1" "ftype(x) \<in> A1"
    "name1(x) \<in> A2" "name1(y) \<in> A2"
    "name2(x) \<in> A3" "name2(x) \<in> A3"
    "cond_of(x) \<in> A4" "cond_of(y) \<in> A4"
    "frecR(x,y)"
  using assms
  unfolding frecrel_def Rrel_def ftype_def by (auto simp add:components_simp)

lemma wf_frecrel :
  shows "wf(frecrel(A))"
proof -
  have "frecrel(A) \<subseteq> measure(A,\<Gamma>)"
    unfolding frecrel_def Rrel_def measure_def
    using \<Gamma>_mono
    by force
  then
  show ?thesis
    using wf_subset wf_measure by auto
qed

lemma core_induction_aux:
  fixes A1 A2 :: "i"
  assumes
    "Transset(A1)"
    "\<And>\<tau> \<theta> p.  p \<in> A2 \<Longrightarrow> \<lbrakk>\<And>q \<sigma>. \<lbrakk> q\<in>A2 ; \<sigma>\<in>domain(\<theta>)\<rbrakk> \<Longrightarrow> Q(0,\<tau>,\<sigma>,q)\<rbrakk> \<Longrightarrow> Q(1,\<tau>,\<theta>,p)"
    "\<And>\<tau> \<theta> p.  p \<in> A2 \<Longrightarrow> \<lbrakk>\<And>q \<sigma>. \<lbrakk> q\<in>A2 ; \<sigma>\<in>domain(\<tau>) \<union> domain(\<theta>)\<rbrakk> \<Longrightarrow> Q(1,\<sigma>,\<tau>,q) \<and> Q(1,\<sigma>,\<theta>,q)\<rbrakk> \<Longrightarrow> Q(0,\<tau>,\<theta>,p)"
  shows "a\<in>2\<times>A1\<times>A1\<times>A2 \<Longrightarrow> Q(ftype(a),name1(a),name2(a),cond_of(a))"
proof (induct a rule:wf_induct[OF wf_frecrel[of "2\<times>A1\<times>A1\<times>A2"]])
  case (1 x)
  let ?\<tau> = "name1(x)"
  let ?\<theta> = "name2(x)"
  let ?D = "2\<times>A1\<times>A1\<times>A2"
  assume "x \<in> ?D"
  then
  have "cond_of(x)\<in>A2"
    by (auto simp add:components_simp)
  from \<open>x\<in>?D\<close>
  consider (eq) "ftype(x)=0" | (mem) "ftype(x)=1"
    by (auto simp add:components_simp)
  then
  show ?case
  proof cases
    case eq
    then
    have "Q(1, \<sigma>, ?\<tau>, q) \<and> Q(1, \<sigma>, ?\<theta>, q)" if "\<sigma> \<in> domain(?\<tau>) \<union> domain(?\<theta>)" and "q\<in>A2" for q \<sigma>
    proof -
      from 1
      have "?\<tau>\<in>A1" "?\<theta>\<in>A1" "?\<tau>\<in>eclose(A1)" "?\<theta>\<in>eclose(A1)"
        using  arg_into_eclose
        by (auto simp add:components_simp)
      moreover from \<open>Transset(A1)\<close> that(1)
      have "\<sigma>\<in>eclose(?\<tau>) \<union> eclose(?\<theta>)"
        using in_dom_in_eclose
        by auto
      then
      have "\<sigma>\<in>A1"
        using mem_eclose_subset[OF \<open>?\<tau>\<in>A1\<close>] mem_eclose_subset[OF \<open>?\<theta>\<in>A1\<close>]
          Transset_eclose_eq_arg[OF \<open>Transset(A1)\<close>]
        by auto
      with \<open>q\<in>A2\<close> \<open>?\<theta> \<in> A1\<close> \<open>cond_of(x)\<in>A2\<close> \<open>?\<tau>\<in>A1\<close>
      have "frecR(\<langle>1, \<sigma>, ?\<tau>, q\<rangle>, x)" (is "frecR(?T,_)")
           "frecR(\<langle>1, \<sigma>, ?\<theta>, q\<rangle>, x)" (is "frecR(?U,_)")
        using frecRI1'[OF that(1)] frecR_DI  \<open>ftype(x) = 0\<close>
          frecRI2'[OF that(1)]
        by (auto simp add:components_simp)
      with \<open>x\<in>?D\<close> \<open>\<sigma>\<in>A1\<close> \<open>q\<in>A2\<close>
      have "\<langle>?T,x\<rangle>\<in> frecrel(?D)" "\<langle>?U,x\<rangle>\<in> frecrel(?D)"
        using frecrelI[of ?T ?D x]  frecrelI[of ?U ?D x]
        by (auto simp add:components_simp)
      with \<open>q\<in>A2\<close> \<open>\<sigma>\<in>A1\<close> \<open>?\<tau>\<in>A1\<close> \<open>?\<theta>\<in>A1\<close>
      have "Q(1, \<sigma>, ?\<tau>, q)"
        using 1
        by (force simp add:components_simp)
      moreover from \<open>q\<in>A2\<close> \<open>\<sigma>\<in>A1\<close> \<open>?\<tau>\<in>A1\<close> \<open>?\<theta>\<in>A1\<close> \<open>\<langle>?U,x\<rangle>\<in> frecrel(?D)\<close>
      have "Q(1, \<sigma>, ?\<theta>, q)"
        using 1 by (force simp add:components_simp)
      ultimately
      show ?thesis
        by simp
    qed
    with assms(3) \<open>ftype(x) = 0\<close> \<open>cond_of(x)\<in>A2\<close>
    show ?thesis
      by auto
  next
    case mem
    have "Q(0, ?\<tau>,  \<sigma>, q)" if "\<sigma> \<in> domain(?\<theta>)" and "q\<in>A2" for q \<sigma>
    proof -
      from 1 assms
      have "?\<tau>\<in>A1" "?\<theta>\<in>A1" "cond_of(x)\<in>A2" "?\<tau>\<in>eclose(A1)" "?\<theta>\<in>eclose(A1)"
        using arg_into_eclose
        by (auto simp add:components_simp)
      with  \<open>Transset(A1)\<close> that(1)
      have "\<sigma>\<in> eclose(?\<theta>)"
        using in_dom_in_eclose
        by auto
      then
      have "\<sigma>\<in>A1"
        using mem_eclose_subset[OF \<open>?\<theta>\<in>A1\<close>] Transset_eclose_eq_arg[OF \<open>Transset(A1)\<close>]
        by auto
      with \<open>q\<in>A2\<close> \<open>?\<theta> \<in> A1\<close> \<open>cond_of(x)\<in>A2\<close> \<open>?\<tau>\<in>A1\<close> \<open>ftype(x) = 1\<close>
      have "frecR(\<langle>0, ?\<tau>, \<sigma>, q\<rangle>, x)" (is "frecR(?T,_)")
        using frecRI3'[OF that(1)] frecR_DI
        by (auto simp add:components_simp)
      with \<open>x\<in>?D\<close> \<open>\<sigma>\<in>A1\<close> \<open>q\<in>A2\<close> \<open>?\<tau>\<in>A1\<close>
      have "\<langle>?T,x\<rangle>\<in> frecrel(?D)" "?T\<in>?D"
        using frecrelI[of ?T ?D x]
        by (auto simp add:components_simp)
      with \<open>q\<in>A2\<close> \<open>\<sigma>\<in>A1\<close> \<open>?\<tau>\<in>A1\<close> \<open>?\<theta>\<in>A1\<close> 1
      show ?thesis
        by (force simp add:components_simp)
    qed
    with assms(2) \<open>ftype(x) = 1\<close> \<open>cond_of(x)\<in>A2\<close>
    show ?thesis
      by auto
  qed
qed

lemma def_frecrel : "frecrel(A) = {z\<in>A\<times>A. \<exists>x y. z = \<langle>x, y\<rangle> \<and> frecR(x,y)}"
  unfolding frecrel_def Rrel_def ..

lemma frecrel_fst_snd:
  "frecrel(A) = {z \<in> A\<times>A .
            ftype(fst(z)) = 1 \<and>
        ftype(snd(z)) = 0 \<and> name1(fst(z)) \<in> domain(name1(snd(z))) \<union> domain(name2(snd(z))) \<and>
            (name2(fst(z)) = name1(snd(z)) \<or> name2(fst(z)) = name2(snd(z)))
          \<or> (ftype(fst(z)) = 0 \<and>
        ftype(snd(z)) = 1 \<and>  name1(fst(z)) = name1(snd(z)) \<and> name2(fst(z)) \<in> domain(name2(snd(z))))}"
  unfolding def_frecrel frecR_def
  by (intro equalityI subsetI CollectI; elim CollectE; auto)

end


(*<*)(*:maxLineLen=68:*)
theory sbElem
  imports Channel
begin
(*>*)

declare %invisible[[show_types]]
declare %invisible[[show_consts]]

default_sort %invisible chan
(* Move to prelude and add mono2mono rules
section \<open> mono2mono\<close>
named_theorems mono2mono "monofun intro rule"
*)
section \<open>Stream Bundle Elements \label{sec:sbelem}\<close>

text\<open>Before we define the \gls{sb} datatype, we define a type for
stream bundle elements. It is a function from a @{class chan} type
to a message @{type M} in @{const ctype} and quite useful in our
later theories. But how can we define a non partial function, if the
domain of our type is empty? Then the function can never map to any
message in @{const ctype}. To still retain the totality property in
all possible cases, we define a stream bundle element as some total
function, if the domain is not empty, and as nothing (@{const None})
if the domain is empty.\<close>

subsection \<open>sbElem Definition \label{sub:sbedef}\<close>

fun sbElem_well :: "('c \<Rightarrow> M) option \<Rightarrow> bool" where
"sbElem_well None = chDomEmpty TYPE('c)" |
"sbElem_well (Some sbe) = (\<forall>c. sbe c \<in> ctype((Rep::'c\<Rightarrow>channel) c))"
(*cbot ist leer, daher wird das nie wahr sein für das leere Bündel*)

text\<open>Predicate @{const sbElem_well} exactly describes our
requirements. The @{type option} type in our predicate allows us to
have the (@{const None}) function, iff the domain of our channel
type is empty. For all non-empty domains, a total function is a
sbElem, iff it only maps to messages in the @{const ctype} of the
channel. With those preparations we now define the sbElem type:\<close>

typedef 'c sbElem ("(_\<^sup>\<surd>)"[1000] 999) =
        "{f::('c \<Rightarrow> M) option. sbElem_well f}"
proof(cases "chDomEmpty(TYPE('c))")
  case True
  then show ?thesis
    apply(rule_tac x=None in exI)
    by (simp add: chDom_def)
next
  case False
  then have "\<forall>c\<in>(range (Rep::'c\<Rightarrow>channel)). ctype c \<noteq> {}"
    using cEmpty_def chDom_def chan_botsingle by blast
  then have "sbElem_well
             (Some(\<lambda>(c::'c). (SOME m. m \<in> ctype (Rep c))))"
    apply(simp add: sbElem_well.cases,auto)
    by (simp add: some_in_eq)
  then show ?thesis
    by blast
qed

text\<open>From our different time types, we will derive the abstract
interpretation of a @{type sbElem} with no empty domain for the
timed cases:
  \<^item> Time synchronous: exactly one message from @{type M}
  \<^item> Timed: exactly on list of message from @{type M_pure}

Hence, the a @{type sbElem} is a time slice. It contains maximal one
message for the synchronous case and arbitrarily, but not
infinitely many messages in the asynchronous case.\<close>

text\<open>The order of @{type sbElem}s then has to be a discrete one.
Else it order would be inconsistent to our prefix order on streams
and also the resulting \gls{sb} order.\<close>

instantiation  sbElem::(chan)discrete_cpo
begin
  definition "below_sbElem = (\<lambda>(sbe1::'a sbElem) sbe2. sbe1 = sbe2)"
instance
  by(standard, simp add: below_sbElem_def)
end

lemma sbe_eqI:"Rep_sbElem sbe1 = Rep_sbElem sbe2 \<Longrightarrow> sbe1 = sbe2"
  by (simp add: Rep_sbElem_inject)

lemma sbelemwell2fwell[simp]:"Rep_sbElem sbe = f \<Longrightarrow> sbElem_well f"
  using Rep_sbElem by auto

subsection\<open>sbElem properties \label{sub:sbeprop}\<close>

lemma sbtypeempty_sbewell:"chDomEmpty TYPE ('cs)
                          \<Longrightarrow> sbElem_well (None::('cs \<Rightarrow> M) option)"
  by(simp add: chDom_def)

lemma sbtypeempty_notsbewell:"chDomEmpty TYPE ('cs)
                           \<Longrightarrow> \<not>sbElem_well (Some (f::'cs \<Rightarrow> M))"
  apply(simp add: chDom_def)
  by (simp add: cEmpty_def image_subset_iff)

text\<open>The following three theorems describe the behaviour of the
@{type sbElem} type for empty and non-empty domains. Hence, they
verify the desired properties of our type.\<close>

theorem sbtypeepmpty_sbenone[simp]:
"chDomEmpty TYPE ('cs) \<Longrightarrow> (sbe::'cs\<^sup>\<surd>) = Abs_sbElem(None)"
  apply(simp add: chDom_def)
  apply(rule sbe_eqI)
  by (metis Diff_eq_empty_iff not_Some_eq Rep_sbElem mem_Collect_eq
      chDom_def sbtypeempty_notsbewell)

text\<open>In case of the empty domain, any @{type sbElem} is
@{const None}. Hence, we now have to look at the behaviour for
non-empty domains.\<close>

theorem [simp]:
"\<not>(chDomEmpty TYPE ('c)) \<Longrightarrow> Rep_sbElem (sbe::'c\<^sup>\<surd>) \<noteq> None"
  using sbElem_well.simps(1) sbelemwell2fwell by blast

text\<open>First we show that a sbElem with a non-empty domain never is
@{const None}. Thus, it is easy to show that there always exists a
total function, that is an @{type sbElem}, if the domain is empty.
It follows directly from the non-emptiness of a type.\<close>

theorem sbtypenotempty_somesbe:
"\<not>(chDomEmpty TYPE ('c)) \<Longrightarrow> \<exists>f::'c \<Rightarrow> M. sbElem_well (Some f)"
  using sbElem_well.simps(1) sbelemwell2fwell by blast

setup_lifting %invisible type_definition_sbElem
(*<*) (*Not in pdf at the moment, because ugly*)
subsection \<open>sbElem functions \label{sub:sbefun}\<close>

text\<open>This function retrieves an element on channel e from the
sbElem. This only works if Elements are allowed on channel e and
channel e is also in type c.\<close>
(*works if sbe \<noteq> None* and 'e \<subseteq> 'c *)
definition sbegetch::"'e \<Rightarrow> 'c\<^sup>\<surd> \<Rightarrow> M"where
"sbegetch c = (\<lambda> sbe. ((the (Rep_sbElem sbe)) (Abs (Rep c))))"

lemma sbtypenotempty_fex[simp]:
"\<not>(chDomEmpty TYPE ('cs)) \<Longrightarrow> \<exists>f. Rep_sbElem (sbe::'cs\<^sup>\<surd>) = (Some f)"
  apply(rule_tac x="(\<lambda>(c::'c). (THE m. m= sbegetch c sbe))" in exI)
  by(simp add: sbegetch_def)

text\<open>This function Converts the Domain of an sbElem. This works if
the Domain it converts to, is smaller or equal\<close>
definition sbeConvert::"'c\<^sup>\<surd> \<Rightarrow> 'd\<^sup>\<surd>"where
"sbeConvert = (\<lambda>sbe. Abs_sbElem(Some (\<lambda>c. sbegetch c sbe)))"

lemma chDomEmpty2chDomEmpty:"chDomEmpty TYPE ('c) \<Longrightarrow>
  Rep (c::'c) \<in> range(Rep::'d\<Rightarrow> channel) \<Longrightarrow> chDomEmpty TYPE ('d)"
  apply(simp add: chDom_def cEmpty_def,auto)
  by (metis (mono_tags, lifting) Int_Collect cEmpty_def
      chan_botsingle insert_not_empty le_iff_inf mk_disjoint_insert
      repinrange)

lemma sbgetch_ctype:
  assumes "Rep (c::'e) \<in> range(Rep::'d \<Rightarrow> channel)"
  and "\<not>chDomEmpty(TYPE('d))"
  shows "sbegetch c (sbe2::'d\<^sup>\<surd>) \<in> ctype ((Rep::'e \<Rightarrow> channel) c)"
  using assms apply(simp add: sbegetch_def)
  by (metis (no_types, hide_lams) assms(1) assms(2) f_inv_into_f
      option.sel sbElem_well.simps(2) sbegetch_def sbelemwell2fwell
      sbtypenotempty_fex)

lemma sberestrict_getch:
  assumes"Rep (c::'c) \<in> range(Rep::'d \<Rightarrow> channel)"
  and "\<not>(chDomEmpty TYPE('c))"
  and "range(Rep::'d \<Rightarrow> channel) \<subseteq> range(Rep::'c \<Rightarrow> channel)"
  shows "sbegetch c ((sbeConvert::'c\<^sup>\<surd> \<Rightarrow> 'd\<^sup>\<surd>) sbe) = sbegetch c sbe"
  using assms
  apply(simp add: sbeConvert_def)
  apply(simp add: sbegetch_def)
  apply(subst Abs_sbElem_inverse)
  apply (smt Rep_sbElem chDom_def f_inv_into_f mem_Collect_eq
         option.sel rangeI sbElem_well.elims(1) sbElem_well.simps(2)
         subset_iff)
  by simp

text\<open>This unites two sbElems. It works, if type e is a subset of the
     union of
     type c and d. First sbElem has priority\<close>
definition sbeUnion::"'c\<^sup>\<surd> \<Rightarrow> 'd\<^sup>\<surd> \<Rightarrow> 'e\<^sup>\<surd>"where
"sbeUnion = (\<lambda>sbe1 sbe2. Abs_sbElem (Some(\<lambda> c.
if (Rep c \<in> (range (Rep ::'c \<Rightarrow> channel)))
    then sbegetch c sbe1
    else  sbegetch c sbe2)))"

lemma sbeunion_getchfst:
  assumes "Rep (c::'c) \<in> range(Rep::'e \<Rightarrow> channel)"
  and "\<not>(chDomEmpty TYPE('c))"
  and "range(Rep::'e \<Rightarrow> channel) \<subseteq>
       range(Rep::'c \<Rightarrow> channel) \<union> range(Rep::'d \<Rightarrow> channel)"
  shows "sbegetch c ((sbeUnion::'c\<^sup>\<surd> \<Rightarrow> 'd\<^sup>\<surd> \<Rightarrow> 'e\<^sup>\<surd>) sbe1 sbe2)
       = sbegetch c sbe1"
  apply(simp add: sbeUnion_def sbegetch_def)
  apply(subst Abs_sbElem_inverse)
  apply (auto simp add: chDom_def assms)
  using assms(2) sbgetch_ctype apply force
  apply (smt assms(2) sbElem_well.simps(2) Un_iff assms(1) assms(3)
         chDomEmpty2chDomEmpty chan_eq repinrange sbgetch_ctype
         subset_eq)
  by(simp add: sbegetch_def assms)

lemma sbeunion_getchsnd:
  assumes "Rep (c::'d) \<in> range(Rep::'e \<Rightarrow> channel)"
  and "Rep c \<notin> range(Rep::'c \<Rightarrow> channel)"
  and "\<not>(chDomEmpty TYPE('d))"
  and "range(Rep::'e \<Rightarrow> channel) \<subseteq>
       range(Rep::'c \<Rightarrow> channel) \<union> range(Rep::'d \<Rightarrow> channel)"
shows"sbegetch c ((sbeUnion::'c\<^sup>\<surd> \<Rightarrow> 'd\<^sup>\<surd> \<Rightarrow> 'e\<^sup>\<surd>) sbe1 sbe2) =
      sbegetch c sbe2"
  apply(simp add: sbeUnion_def sbegetch_def)
  apply(subst Abs_sbElem_inverse)
  apply (auto simp add: chDom_def assms)
  apply (metis assms(1) assms(3) chDomEmpty2chDomEmpty chan_eq
         rangeI sbgetch_ctype)
  apply (smt assms sbElem_well.simps(2) Un_iff assms(1) assms(3)
         chDomEmpty2chDomEmpty chan_eq repinrange sbgetch_ctype
         subset_eq)
  by(simp add: sbegetch_def assms)
(*>*)

(*<*)
end
(*>*)


(* Author: Joshua Schneider, ETH Zurich
   Author: Andreas Lochbihler, ETH Zurich *)

section \<open>An abstract applicative functor\<close>

theory Abstract_AF imports
  Applicative
  "HOL-Library.Adhoc_Overloading"
begin

typedef 'a af = "UNIV :: 'a set" ..

setup_lifting type_definition_af

abbreviation "af_pure \<equiv> Abs_af"
lift_definition af_ap :: "('a \<Rightarrow> 'b) af \<Rightarrow> 'a af \<Rightarrow> 'b af" is "\<lambda>f x. f x" .

adhoc_overloading Applicative.pure Abs_af
adhoc_overloading Applicative.ap af_ap

context includes applicative_syntax
begin

lemma af_identity: "af_pure id \<diamondop> x = x"
by transfer simp

lemma af_homomorphism: "af_pure f \<diamondop> af_pure x = af_pure (f x)"
by(fact af_ap.abs_eq)

lemma af_composition: "af_pure comp \<diamondop> g \<diamondop> f \<diamondop> x = g \<diamondop> (f \<diamondop> x)"
by transfer simp

lemma af_interchange: "f \<diamondop> af_pure x = af_pure (\<lambda>g. g x) \<diamondop> f"
by transfer simp

end

lifting_forget af.lifting

hide_const Abs_af Rep_af
hide_fact af_ap_def

applicative af
for
  pure: af_pure
  ap: af_ap
using af_homomorphism af_composition af_identity af_interchange
unfolding id_def comp_def[abs_def]
.

end