(* Author: Tobias Nipkow *)

section \<open>2-3-4 Tree Implementation of Sets\<close>

theory Tree234_Set
imports
  Tree234
  Cmp
  Set_Specs
begin

declare sorted_wrt.simps(2)[simp del]

subsection \<open>Set operations on 2-3-4 trees\<close>

definition empty :: "'a tree234" where
"empty = Leaf"

fun isin :: "'a::linorder tree234 \<Rightarrow> 'a \<Rightarrow> bool" where
"isin Leaf x = False" |
"isin (Node2 l a r) x =
  (case cmp x a of LT \<Rightarrow> isin l x | EQ \<Rightarrow> True | GT \<Rightarrow> isin r x)" |
"isin (Node3 l a m b r) x =
  (case cmp x a of LT \<Rightarrow> isin l x | EQ \<Rightarrow> True | GT \<Rightarrow> (case cmp x b of
   LT \<Rightarrow> isin m x | EQ \<Rightarrow> True | GT \<Rightarrow> isin r x))" |
"isin (Node4 t1 a t2 b t3 c t4) x =
  (case cmp x b of
     LT \<Rightarrow>
       (case cmp x a of
          LT \<Rightarrow> isin t1 x |
          EQ \<Rightarrow> True |
          GT \<Rightarrow> isin t2 x) |
     EQ \<Rightarrow> True |
     GT \<Rightarrow>
       (case cmp x c of
          LT \<Rightarrow> isin t3 x |
          EQ \<Rightarrow> True |
          GT \<Rightarrow> isin t4 x))"

datatype 'a up\<^sub>i = T\<^sub>i "'a tree234" | Up\<^sub>i "'a tree234" 'a "'a tree234"

fun tree\<^sub>i :: "'a up\<^sub>i \<Rightarrow> 'a tree234" where
"tree\<^sub>i (T\<^sub>i t) = t" |
"tree\<^sub>i (Up\<^sub>i l a r) = Node2 l a r"

fun ins :: "'a::linorder \<Rightarrow> 'a tree234 \<Rightarrow> 'a up\<^sub>i" where
"ins x Leaf = Up\<^sub>i Leaf x Leaf" |
"ins x (Node2 l a r) =
   (case cmp x a of
      LT \<Rightarrow> (case ins x l of
              T\<^sub>i l' => T\<^sub>i (Node2 l' a r)
            | Up\<^sub>i l1 b l2 => T\<^sub>i (Node3 l1 b l2 a r)) |
      EQ \<Rightarrow> T\<^sub>i (Node2 l x r) |
      GT \<Rightarrow> (case ins x r of
              T\<^sub>i r' => T\<^sub>i (Node2 l a r')
            | Up\<^sub>i r1 b r2 => T\<^sub>i (Node3 l a r1 b r2)))" |
"ins x (Node3 l a m b r) =
   (case cmp x a of
      LT \<Rightarrow> (case ins x l of
              T\<^sub>i l' => T\<^sub>i (Node3 l' a m b r)
            | Up\<^sub>i l1 c l2 => Up\<^sub>i (Node2 l1 c l2) a (Node2 m b r)) |
      EQ \<Rightarrow> T\<^sub>i (Node3 l a m b r) |
      GT \<Rightarrow> (case cmp x b of
               GT \<Rightarrow> (case ins x r of
                       T\<^sub>i r' => T\<^sub>i (Node3 l a m b r')
                     | Up\<^sub>i r1 c r2 => Up\<^sub>i (Node2 l a m) b (Node2 r1 c r2)) |
               EQ \<Rightarrow> T\<^sub>i (Node3 l a m b r) |
               LT \<Rightarrow> (case ins x m of
                       T\<^sub>i m' => T\<^sub>i (Node3 l a m' b r)
                     | Up\<^sub>i m1 c m2 => Up\<^sub>i (Node2 l a m1) c (Node2 m2 b r))))" |
"ins x (Node4 t1 a t2 b t3 c t4) =
  (case cmp x b of
     LT \<Rightarrow>
       (case cmp x a of
          LT \<Rightarrow>
            (case ins x t1 of
               T\<^sub>i t => T\<^sub>i (Node4 t a t2 b t3 c t4) |
               Up\<^sub>i l y r => Up\<^sub>i (Node2 l y r) a (Node3 t2 b t3 c t4)) |
          EQ \<Rightarrow> T\<^sub>i (Node4 t1 a t2 b t3 c t4) |
          GT \<Rightarrow>
            (case ins x t2 of
               T\<^sub>i t => T\<^sub>i (Node4 t1 a t b t3 c t4) |
               Up\<^sub>i l y r => Up\<^sub>i (Node2 t1 a l) y (Node3 r b t3 c t4))) |
     EQ \<Rightarrow> T\<^sub>i (Node4 t1 a t2 b t3 c t4) |
     GT \<Rightarrow>
       (case cmp x c of
          LT \<Rightarrow>
            (case ins x t3 of
              T\<^sub>i t => T\<^sub>i (Node4 t1 a t2 b t c t4) |
              Up\<^sub>i l y r => Up\<^sub>i (Node2 t1 a t2) b (Node3 l y r c t4)) |
          EQ \<Rightarrow> T\<^sub>i (Node4 t1 a t2 b t3 c t4) |
          GT \<Rightarrow>
            (case ins x t4 of
              T\<^sub>i t => T\<^sub>i (Node4 t1 a t2 b t3 c t) |
              Up\<^sub>i l y r => Up\<^sub>i (Node2 t1 a t2) b (Node3 t3 c l y r))))"

hide_const insert

definition insert :: "'a::linorder \<Rightarrow> 'a tree234 \<Rightarrow> 'a tree234" where
"insert x t = tree\<^sub>i(ins x t)"

datatype 'a up\<^sub>d = T\<^sub>d "'a tree234" | Up\<^sub>d "'a tree234"

fun tree\<^sub>d :: "'a up\<^sub>d \<Rightarrow> 'a tree234" where
"tree\<^sub>d (T\<^sub>d t) = t" |
"tree\<^sub>d (Up\<^sub>d t) = t"

fun node21 :: "'a up\<^sub>d \<Rightarrow> 'a \<Rightarrow> 'a tree234 \<Rightarrow> 'a up\<^sub>d" where
"node21 (T\<^sub>d l) a r = T\<^sub>d(Node2 l a r)" |
"node21 (Up\<^sub>d l) a (Node2 lr b rr) = Up\<^sub>d(Node3 l a lr b rr)" |
"node21 (Up\<^sub>d l) a (Node3 lr b mr c rr) = T\<^sub>d(Node2 (Node2 l a lr) b (Node2 mr c rr))" |
"node21 (Up\<^sub>d t1) a (Node4 t2 b t3 c t4 d t5) = T\<^sub>d(Node2 (Node2 t1 a t2) b (Node3 t3 c t4 d t5))"

fun node22 :: "'a tree234 \<Rightarrow> 'a \<Rightarrow> 'a up\<^sub>d \<Rightarrow> 'a up\<^sub>d" where
"node22 l a (T\<^sub>d r) = T\<^sub>d(Node2 l a r)" |
"node22 (Node2 ll b rl) a (Up\<^sub>d r) = Up\<^sub>d(Node3 ll b rl a r)" |
"node22 (Node3 ll b ml c rl) a (Up\<^sub>d r) = T\<^sub>d(Node2 (Node2 ll b ml) c (Node2 rl a r))" |
"node22 (Node4 t1 a t2 b t3 c t4) d (Up\<^sub>d t5) = T\<^sub>d(Node2 (Node2 t1 a t2) b (Node3 t3 c t4 d t5))"

fun node31 :: "'a up\<^sub>d \<Rightarrow> 'a \<Rightarrow> 'a tree234 \<Rightarrow> 'a \<Rightarrow> 'a tree234 \<Rightarrow> 'a up\<^sub>d" where
"node31 (T\<^sub>d t1) a t2 b t3 = T\<^sub>d(Node3 t1 a t2 b t3)" |
"node31 (Up\<^sub>d t1) a (Node2 t2 b t3) c t4 = T\<^sub>d(Node2 (Node3 t1 a t2 b t3) c t4)" |
"node31 (Up\<^sub>d t1) a (Node3 t2 b t3 c t4) d t5 = T\<^sub>d(Node3 (Node2 t1 a t2) b (Node2 t3 c t4) d t5)" |
"node31 (Up\<^sub>d t1) a (Node4 t2 b t3 c t4 d t5) e t6 = T\<^sub>d(Node3 (Node2 t1 a t2) b (Node3 t3 c t4 d t5) e t6)"

fun node32 :: "'a tree234 \<Rightarrow> 'a \<Rightarrow> 'a up\<^sub>d \<Rightarrow> 'a \<Rightarrow> 'a tree234 \<Rightarrow> 'a up\<^sub>d" where
"node32 t1 a (T\<^sub>d t2) b t3 = T\<^sub>d(Node3 t1 a t2 b t3)" |
"node32 t1 a (Up\<^sub>d t2) b (Node2 t3 c t4) = T\<^sub>d(Node2 t1 a (Node3 t2 b t3 c t4))" |
"node32 t1 a (Up\<^sub>d t2) b (Node3 t3 c t4 d t5) = T\<^sub>d(Node3 t1 a (Node2 t2 b t3) c (Node2 t4 d t5))" |
"node32 t1 a (Up\<^sub>d t2) b (Node4 t3 c t4 d t5 e t6) = T\<^sub>d(Node3 t1 a (Node2 t2 b t3) c (Node3 t4 d t5 e t6))"

fun node33 :: "'a tree234 \<Rightarrow> 'a \<Rightarrow> 'a tree234 \<Rightarrow> 'a \<Rightarrow> 'a up\<^sub>d \<Rightarrow> 'a up\<^sub>d" where
"node33 l a m b (T\<^sub>d r) = T\<^sub>d(Node3 l a m b r)" |
"node33 t1 a (Node2 t2 b t3) c (Up\<^sub>d t4) = T\<^sub>d(Node2 t1 a (Node3 t2 b t3 c t4))" |
"node33 t1 a (Node3 t2 b t3 c t4) d (Up\<^sub>d t5) = T\<^sub>d(Node3 t1 a (Node2 t2 b t3) c (Node2 t4 d t5))" |
"node33 t1 a (Node4 t2 b t3 c t4 d t5) e (Up\<^sub>d t6) = T\<^sub>d(Node3 t1 a (Node2 t2 b t3) c (Node3 t4 d t5 e t6))"

fun node41 :: "'a up\<^sub>d \<Rightarrow> 'a \<Rightarrow> 'a tree234 \<Rightarrow> 'a \<Rightarrow> 'a tree234 \<Rightarrow> 'a \<Rightarrow> 'a tree234 \<Rightarrow> 'a up\<^sub>d" where
"node41 (T\<^sub>d t1) a t2 b t3 c t4 = T\<^sub>d(Node4 t1 a t2 b t3 c t4)" |
"node41 (Up\<^sub>d t1) a (Node2 t2 b t3) c t4 d t5 = T\<^sub>d(Node3 (Node3 t1 a t2 b t3) c t4 d t5)" |
"node41 (Up\<^sub>d t1) a (Node3 t2 b t3 c t4) d t5 e t6 = T\<^sub>d(Node4 (Node2 t1 a t2) b (Node2 t3 c t4) d t5 e t6)" |
"node41 (Up\<^sub>d t1) a (Node4 t2 b t3 c t4 d t5) e t6 f t7 = T\<^sub>d(Node4 (Node2 t1 a t2) b (Node3 t3 c t4 d t5) e t6 f t7)"

fun node42 :: "'a tree234 \<Rightarrow> 'a \<Rightarrow> 'a up\<^sub>d \<Rightarrow> 'a \<Rightarrow> 'a tree234 \<Rightarrow> 'a \<Rightarrow> 'a tree234 \<Rightarrow> 'a up\<^sub>d" where
"node42 t1 a (T\<^sub>d t2) b t3 c t4 = T\<^sub>d(Node4 t1 a t2 b t3 c t4)" |
"node42 (Node2 t1 a t2) b (Up\<^sub>d t3) c t4 d t5 = T\<^sub>d(Node3 (Node3 t1 a t2 b t3) c t4 d t5)" |
"node42 (Node3 t1 a t2 b t3) c (Up\<^sub>d t4) d t5 e t6 = T\<^sub>d(Node4 (Node2 t1 a t2) b (Node2 t3 c t4) d t5 e t6)" |
"node42 (Node4 t1 a t2 b t3 c t4) d (Up\<^sub>d t5) e t6 f t7 = T\<^sub>d(Node4 (Node2 t1 a t2) b (Node3 t3 c t4 d t5) e t6 f t7)"

fun node43 :: "'a tree234 \<Rightarrow> 'a \<Rightarrow> 'a tree234 \<Rightarrow> 'a \<Rightarrow> 'a up\<^sub>d \<Rightarrow> 'a \<Rightarrow> 'a tree234 \<Rightarrow> 'a up\<^sub>d" where
"node43 t1 a t2 b (T\<^sub>d t3) c t4 = T\<^sub>d(Node4 t1 a t2 b t3 c t4)" |
"node43 t1 a (Node2 t2 b t3) c (Up\<^sub>d t4) d t5 = T\<^sub>d(Node3 t1 a (Node3 t2 b t3 c t4) d t5)" |
"node43 t1 a (Node3 t2 b t3 c t4) d (Up\<^sub>d t5) e t6 = T\<^sub>d(Node4 t1 a (Node2 t2 b t3) c (Node2 t4 d t5) e t6)" |
"node43 t1 a (Node4 t2 b t3 c t4 d t5) e (Up\<^sub>d t6) f t7 = T\<^sub>d(Node4 t1 a (Node2 t2 b t3) c (Node3 t4 d t5 e t6) f t7)"

fun node44 :: "'a tree234 \<Rightarrow> 'a \<Rightarrow> 'a tree234 \<Rightarrow> 'a \<Rightarrow> 'a tree234 \<Rightarrow> 'a \<Rightarrow> 'a up\<^sub>d \<Rightarrow> 'a up\<^sub>d" where
"node44 t1 a t2 b t3 c (T\<^sub>d t4) = T\<^sub>d(Node4 t1 a t2 b t3 c t4)" |
"node44 t1 a t2 b (Node2 t3 c t4) d (Up\<^sub>d t5) = T\<^sub>d(Node3 t1 a t2 b (Node3 t3 c t4 d t5))" |
"node44 t1 a t2 b (Node3 t3 c t4 d t5) e (Up\<^sub>d t6) = T\<^sub>d(Node4 t1 a t2 b (Node2 t3 c t4) d (Node2 t5 e t6))" |
"node44 t1 a t2 b (Node4 t3 c t4 d t5 e t6) f (Up\<^sub>d t7) = T\<^sub>d(Node4 t1 a t2 b (Node2 t3 c t4) d (Node3 t5 e t6 f t7))"

fun split_min :: "'a tree234 \<Rightarrow> 'a * 'a up\<^sub>d" where
"split_min (Node2 Leaf a Leaf) = (a, Up\<^sub>d Leaf)" |
"split_min (Node3 Leaf a Leaf b Leaf) = (a, T\<^sub>d(Node2 Leaf b Leaf))" |
"split_min (Node4 Leaf a Leaf b Leaf c Leaf) = (a, T\<^sub>d(Node3 Leaf b Leaf c Leaf))" |
"split_min (Node2 l a r) = (let (x,l') = split_min l in (x, node21 l' a r))" |
"split_min (Node3 l a m b r) = (let (x,l') = split_min l in (x, node31 l' a m b r))" |
"split_min (Node4 l a m b n c r) = (let (x,l') = split_min l in (x, node41 l' a m b n c r))"

fun del :: "'a::linorder \<Rightarrow> 'a tree234 \<Rightarrow> 'a up\<^sub>d" where
"del k Leaf = T\<^sub>d Leaf" |
"del k (Node2 Leaf p Leaf) = (if k=p then Up\<^sub>d Leaf else T\<^sub>d(Node2 Leaf p Leaf))" |
"del k (Node3 Leaf p Leaf q Leaf) = T\<^sub>d(if k=p then Node2 Leaf q Leaf
  else if k=q then Node2 Leaf p Leaf else Node3 Leaf p Leaf q Leaf)" |
"del k (Node4 Leaf a Leaf b Leaf c Leaf) =
  T\<^sub>d(if k=a then Node3 Leaf b Leaf c Leaf else
     if k=b then Node3 Leaf a Leaf c Leaf else
     if k=c then Node3 Leaf a Leaf b Leaf
     else Node4 Leaf a Leaf b Leaf c Leaf)" |
"del k (Node2 l a r) = (case cmp k a of
  LT \<Rightarrow> node21 (del k l) a r |
  GT \<Rightarrow> node22 l a (del k r) |
  EQ \<Rightarrow> let (a',t) = split_min r in node22 l a' t)" |
"del k (Node3 l a m b r) = (case cmp k a of
  LT \<Rightarrow> node31 (del k l) a m b r |
  EQ \<Rightarrow> let (a',m') = split_min m in node32 l a' m' b r |
  GT \<Rightarrow> (case cmp k b of
           LT \<Rightarrow> node32 l a (del k m) b r |
           EQ \<Rightarrow> let (b',r') = split_min r in node33 l a m b' r' |
           GT \<Rightarrow> node33 l a m b (del k r)))" |
"del k (Node4 l a m b n c r) = (case cmp k b of
  LT \<Rightarrow> (case cmp k a of
          LT \<Rightarrow> node41 (del k l) a m b n c r |
          EQ \<Rightarrow> let (a',m') = split_min m in node42 l a' m' b n c r |
          GT \<Rightarrow> node42 l a (del k m) b n c r) |
  EQ \<Rightarrow> let (b',n') = split_min n in node43 l a m b' n' c r |
  GT \<Rightarrow> (case cmp k c of
           LT \<Rightarrow> node43 l a m b (del k n) c r |
           EQ \<Rightarrow> let (c',r') = split_min r in node44 l a m b n c' r' |
           GT \<Rightarrow> node44 l a m b n c (del k r)))"

definition delete :: "'a::linorder \<Rightarrow> 'a tree234 \<Rightarrow> 'a tree234" where
"delete x t = tree\<^sub>d(del x t)"

subsection "Functional correctness"

subsubsection \<open>Functional correctness of isin:\<close>

lemma isin_set: "sorted(inorder t) \<Longrightarrow> isin t x = (x \<in> set (inorder t))"
by (induction t) (auto simp: isin_simps)

subsubsection \<open>Functional correctness of insert:\<close>

lemma inorder_ins:
  "sorted(inorder t) \<Longrightarrow> inorder(tree\<^sub>i(ins x t)) = ins_list x (inorder t)"
by(induction t) (auto, auto simp: ins_list_simps split!: if_splits up\<^sub>i.splits)

lemma inorder_insert:
  "sorted(inorder t) \<Longrightarrow> inorder(insert a t) = ins_list a (inorder t)"
by(simp add: insert_def inorder_ins)

subsubsection \<open>Functional correctness of delete\<close>

lemma inorder_node21: "height r > 0 \<Longrightarrow>
  inorder (tree\<^sub>d (node21 l' a r)) = inorder (tree\<^sub>d l') @ a # inorder r"
by(induct l' a r rule: node21.induct) auto

lemma inorder_node22: "height l > 0 \<Longrightarrow>
  inorder (tree\<^sub>d (node22 l a r')) = inorder l @ a # inorder (tree\<^sub>d r')"
by(induct l a r' rule: node22.induct) auto

lemma inorder_node31: "height m > 0 \<Longrightarrow>
  inorder (tree\<^sub>d (node31 l' a m b r)) = inorder (tree\<^sub>d l') @ a # inorder m @ b # inorder r"
by(induct l' a m b r rule: node31.induct) auto

lemma inorder_node32: "height r > 0 \<Longrightarrow>
  inorder (tree\<^sub>d (node32 l a m' b r)) = inorder l @ a # inorder (tree\<^sub>d m') @ b # inorder r"
by(induct l a m' b r rule: node32.induct) auto

lemma inorder_node33: "height m > 0 \<Longrightarrow>
  inorder (tree\<^sub>d (node33 l a m b r')) = inorder l @ a # inorder m @ b # inorder (tree\<^sub>d r')"
by(induct l a m b r' rule: node33.induct) auto

lemma inorder_node41: "height m > 0 \<Longrightarrow>
  inorder (tree\<^sub>d (node41 l' a m b n c r)) = inorder (tree\<^sub>d l') @ a # inorder m @ b # inorder n @ c # inorder r"
by(induct l' a m b n c r rule: node41.induct) auto

lemma inorder_node42: "height l > 0 \<Longrightarrow>
  inorder (tree\<^sub>d (node42 l a m b n c r)) = inorder l @ a # inorder (tree\<^sub>d m) @ b # inorder n @ c # inorder r"
by(induct l a m b n c r rule: node42.induct) auto

lemma inorder_node43: "height m > 0 \<Longrightarrow>
  inorder (tree\<^sub>d (node43 l a m b n c r)) = inorder l @ a # inorder m @ b # inorder(tree\<^sub>d n) @ c # inorder r"
by(induct l a m b n c r rule: node43.induct) auto

lemma inorder_node44: "height n > 0 \<Longrightarrow>
  inorder (tree\<^sub>d (node44 l a m b n c r)) = inorder l @ a # inorder m @ b # inorder n @ c # inorder (tree\<^sub>d r)"
by(induct l a m b n c r rule: node44.induct) auto

lemmas inorder_nodes = inorder_node21 inorder_node22
  inorder_node31 inorder_node32 inorder_node33
  inorder_node41 inorder_node42 inorder_node43 inorder_node44

lemma split_minD:
  "split_min t = (x,t') \<Longrightarrow> bal t \<Longrightarrow> height t > 0 \<Longrightarrow>
  x # inorder(tree\<^sub>d t') = inorder t"
by(induction t arbitrary: t' rule: split_min.induct)
  (auto simp: inorder_nodes split: prod.splits)

lemma inorder_del: "\<lbrakk> bal t ; sorted(inorder t) \<rbrakk> \<Longrightarrow>
  inorder(tree\<^sub>d (del x t)) = del_list x (inorder t)"
by(induction t rule: del.induct)
  (auto simp: inorder_nodes del_list_simps split_minD split!: if_split prod.splits)
  (* 30 secs (2016) *)

lemma inorder_delete: "\<lbrakk> bal t ; sorted(inorder t) \<rbrakk> \<Longrightarrow>
  inorder(delete x t) = del_list x (inorder t)"
by(simp add: delete_def inorder_del)

subsection \<open>Balancedness\<close>

subsubsection "Proofs for insert"

text\<open>First a standard proof that \<^const>\<open>ins\<close> preserves \<^const>\<open>bal\<close>.\<close>

instantiation up\<^sub>i :: (type)height
begin

fun height_up\<^sub>i :: "'a up\<^sub>i \<Rightarrow> nat" where
"height (T\<^sub>i t) = height t" |
"height (Up\<^sub>i l a r) = height l"

instance ..

end

lemma bal_ins: "bal t \<Longrightarrow> bal (tree\<^sub>i(ins a t)) \<and> height(ins a t) = height t"
by (induct t) (auto split!: if_split up\<^sub>i.split)

text\<open>Now an alternative proof (by Brian Huffman) that runs faster because
two properties (balance and height) are combined in one predicate.\<close>

inductive full :: "nat \<Rightarrow> 'a tree234 \<Rightarrow> bool" where
"full 0 Leaf" |
"\<lbrakk>full n l; full n r\<rbrakk> \<Longrightarrow> full (Suc n) (Node2 l p r)" |
"\<lbrakk>full n l; full n m; full n r\<rbrakk> \<Longrightarrow> full (Suc n) (Node3 l p m q r)" |
"\<lbrakk>full n l; full n m; full n m'; full n r\<rbrakk> \<Longrightarrow> full (Suc n) (Node4 l p m q m' q' r)"

inductive_cases full_elims:
  "full n Leaf"
  "full n (Node2 l p r)"
  "full n (Node3 l p m q r)"
  "full n (Node4 l p m q m' q' r)"

inductive_cases full_0_elim: "full 0 t"
inductive_cases full_Suc_elim: "full (Suc n) t"

lemma full_0_iff [simp]: "full 0 t \<longleftrightarrow> t = Leaf"
  by (auto elim: full_0_elim intro: full.intros)

lemma full_Leaf_iff [simp]: "full n Leaf \<longleftrightarrow> n = 0"
  by (auto elim: full_elims intro: full.intros)

lemma full_Suc_Node2_iff [simp]:
  "full (Suc n) (Node2 l p r) \<longleftrightarrow> full n l \<and> full n r"
  by (auto elim: full_elims intro: full.intros)

lemma full_Suc_Node3_iff [simp]:
  "full (Suc n) (Node3 l p m q r) \<longleftrightarrow> full n l \<and> full n m \<and> full n r"
  by (auto elim: full_elims intro: full.intros)

lemma full_Suc_Node4_iff [simp]:
  "full (Suc n) (Node4 l p m q m' q' r) \<longleftrightarrow> full n l \<and> full n m \<and> full n m' \<and> full n r"
  by (auto elim: full_elims intro: full.intros)

lemma full_imp_height: "full n t \<Longrightarrow> height t = n"
  by (induct set: full, simp_all)

lemma full_imp_bal: "full n t \<Longrightarrow> bal t"
  by (induct set: full, auto dest: full_imp_height)

lemma bal_imp_full: "bal t \<Longrightarrow> full (height t) t"
  by (induct t, simp_all)

lemma bal_iff_full: "bal t \<longleftrightarrow> (\<exists>n. full n t)"
  by (auto elim!: bal_imp_full full_imp_bal)

text \<open>The \<^const>\<open>insert\<close> function either preserves the height of the
tree, or increases it by one. The constructor returned by the \<^term>\<open>insert\<close> function determines which: A return value of the form \<^term>\<open>T\<^sub>i t\<close> indicates that the height will be the same. A value of the
form \<^term>\<open>Up\<^sub>i l p r\<close> indicates an increase in height.\<close>

primrec full\<^sub>i :: "nat \<Rightarrow> 'a up\<^sub>i \<Rightarrow> bool" where
"full\<^sub>i n (T\<^sub>i t) \<longleftrightarrow> full n t" |
"full\<^sub>i n (Up\<^sub>i l p r) \<longleftrightarrow> full n l \<and> full n r"

lemma full\<^sub>i_ins: "full n t \<Longrightarrow> full\<^sub>i n (ins a t)"
by (induct rule: full.induct) (auto, auto split: up\<^sub>i.split)

text \<open>The \<^const>\<open>insert\<close> operation preserves balance.\<close>

lemma bal_insert: "bal t \<Longrightarrow> bal (insert a t)"
unfolding bal_iff_full insert_def
apply (erule exE)
apply (drule full\<^sub>i_ins [of _ _ a])
apply (cases "ins a t")
apply (auto intro: full.intros)
done

subsubsection "Proofs for delete"

instantiation up\<^sub>d :: (type)height
begin

fun height_up\<^sub>d :: "'a up\<^sub>d \<Rightarrow> nat" where
"height (T\<^sub>d t) = height t" |
"height (Up\<^sub>d t) = height t + 1"

instance ..

end

lemma bal_tree\<^sub>d_node21:
  "\<lbrakk>bal r; bal (tree\<^sub>d l); height r = height l \<rbrakk> \<Longrightarrow> bal (tree\<^sub>d (node21 l a r))"
by(induct l a r rule: node21.induct) auto

lemma bal_tree\<^sub>d_node22:
  "\<lbrakk>bal(tree\<^sub>d r); bal l; height r = height l \<rbrakk> \<Longrightarrow> bal (tree\<^sub>d (node22 l a r))"
by(induct l a r rule: node22.induct) auto

lemma bal_tree\<^sub>d_node31:
  "\<lbrakk> bal (tree\<^sub>d l); bal m; bal r; height l = height r; height m = height r \<rbrakk>
  \<Longrightarrow> bal (tree\<^sub>d (node31 l a m b r))"
by(induct l a m b r rule: node31.induct) auto

lemma bal_tree\<^sub>d_node32:
  "\<lbrakk> bal l; bal (tree\<^sub>d m); bal r; height l = height r; height m = height r \<rbrakk>
  \<Longrightarrow> bal (tree\<^sub>d (node32 l a m b r))"
by(induct l a m b r rule: node32.induct) auto

lemma bal_tree\<^sub>d_node33:
  "\<lbrakk> bal l; bal m; bal(tree\<^sub>d r); height l = height r; height m = height r \<rbrakk>
  \<Longrightarrow> bal (tree\<^sub>d (node33 l a m b r))"
by(induct l a m b r rule: node33.induct) auto

lemma bal_tree\<^sub>d_node41:
  "\<lbrakk> bal (tree\<^sub>d l); bal m; bal n; bal r; height l = height r; height m = height r; height n = height r \<rbrakk>
  \<Longrightarrow> bal (tree\<^sub>d (node41 l a m b n c r))"
by(induct l a m b n c r rule: node41.induct) auto

lemma bal_tree\<^sub>d_node42:
  "\<lbrakk> bal l; bal (tree\<^sub>d m); bal n; bal r; height l = height r; height m = height r; height n = height r \<rbrakk>
  \<Longrightarrow> bal (tree\<^sub>d (node42 l a m b n c r))"
by(induct l a m b n c r rule: node42.induct) auto

lemma bal_tree\<^sub>d_node43:
  "\<lbrakk> bal l; bal m; bal (tree\<^sub>d n); bal r; height l = height r; height m = height r; height n = height r \<rbrakk>
  \<Longrightarrow> bal (tree\<^sub>d (node43 l a m b n c r))"
by(induct l a m b n c r rule: node43.induct) auto

lemma bal_tree\<^sub>d_node44:
  "\<lbrakk> bal l; bal m; bal n; bal (tree\<^sub>d r); height l = height r; height m = height r; height n = height r \<rbrakk>
  \<Longrightarrow> bal (tree\<^sub>d (node44 l a m b n c r))"
by(induct l a m b n c r rule: node44.induct) auto

lemmas bals = bal_tree\<^sub>d_node21 bal_tree\<^sub>d_node22
  bal_tree\<^sub>d_node31 bal_tree\<^sub>d_node32 bal_tree\<^sub>d_node33
  bal_tree\<^sub>d_node41 bal_tree\<^sub>d_node42 bal_tree\<^sub>d_node43 bal_tree\<^sub>d_node44

lemma height_node21:
   "height r > 0 \<Longrightarrow> height(node21 l a r) = max (height l) (height r) + 1"
by(induct l a r rule: node21.induct)(simp_all add: max.assoc)

lemma height_node22:
   "height l > 0 \<Longrightarrow> height(node22 l a r) = max (height l) (height r) + 1"
by(induct l a r rule: node22.induct)(simp_all add: max.assoc)

lemma height_node31:
  "height m > 0 \<Longrightarrow> height(node31 l a m b r) =
   max (height l) (max (height m) (height r)) + 1"
by(induct l a m b r rule: node31.induct)(simp_all add: max_def)

lemma height_node32:
  "height r > 0 \<Longrightarrow> height(node32 l a m b r) =
   max (height l) (max (height m) (height r)) + 1"
by(induct l a m b r rule: node32.induct)(simp_all add: max_def)

lemma height_node33:
  "height m > 0 \<Longrightarrow> height(node33 l a m b r) =
   max (height l) (max (height m) (height r)) + 1"
by(induct l a m b r rule: node33.induct)(simp_all add: max_def)

lemma height_node41:
  "height m > 0 \<Longrightarrow> height(node41 l a m b n c r) =
   max (height l) (max (height m) (max (height n) (height r))) + 1"
by(induct l a m b n c r rule: node41.induct)(simp_all add: max_def)

lemma height_node42:
  "height l > 0 \<Longrightarrow> height(node42 l a m b n c r) =
   max (height l) (max (height m) (max (height n) (height r))) + 1"
by(induct l a m b n c r rule: node42.induct)(simp_all add: max_def)

lemma height_node43:
  "height m > 0 \<Longrightarrow> height(node43 l a m b n c r) =
   max (height l) (max (height m) (max (height n) (height r))) + 1"
by(induct l a m b n c r rule: node43.induct)(simp_all add: max_def)

lemma height_node44:
  "height n > 0 \<Longrightarrow> height(node44 l a m b n c r) =
   max (height l) (max (height m) (max (height n) (height r))) + 1"
by(induct l a m b n c r rule: node44.induct)(simp_all add: max_def)

lemmas heights = height_node21 height_node22
  height_node31 height_node32 height_node33
  height_node41 height_node42 height_node43 height_node44

lemma height_split_min:
  "split_min t = (x, t') \<Longrightarrow> height t > 0 \<Longrightarrow> bal t \<Longrightarrow> height t' = height t"
by(induct t arbitrary: x t' rule: split_min.induct)
  (auto simp: heights split: prod.splits)

lemma height_del: "bal t \<Longrightarrow> height(del x t) = height t"
by(induction x t rule: del.induct)
  (auto simp add: heights height_split_min split!: if_split prod.split)

lemma bal_split_min:
  "\<lbrakk> split_min t = (x, t'); bal t; height t > 0 \<rbrakk> \<Longrightarrow> bal (tree\<^sub>d t')"
by(induct t arbitrary: x t' rule: split_min.induct)
  (auto simp: heights height_split_min bals split: prod.splits)

lemma bal_tree\<^sub>d_del: "bal t \<Longrightarrow> bal(tree\<^sub>d(del x t))"
by(induction x t rule: del.induct)
  (auto simp: bals bal_split_min height_del height_split_min split!: if_split prod.split)

corollary bal_delete: "bal t \<Longrightarrow> bal(delete x t)"
by(simp add: delete_def bal_tree\<^sub>d_del)

subsection \<open>Overall Correctness\<close>

interpretation S: Set_by_Ordered
where empty = empty and isin = isin and insert = insert and delete = delete
and inorder = inorder and inv = bal
proof (standard, goal_cases)
  case 2 thus ?case by(simp add: isin_set)
next
  case 3 thus ?case by(simp add: inorder_insert)
next
  case 4 thus ?case by(simp add: inorder_delete)
next
  case 6 thus ?case by(simp add: bal_insert)
next
  case 7 thus ?case by(simp add: bal_delete)
qed (simp add: empty_def)+

end


section \<open>Models, Invariants and Refinements\<close>

theory Refinement imports Infra
begin

(******************************************************************************)
subsection \<open>Specifications, reachability, and behaviours.\<close>
(******************************************************************************)

text \<open>Transition systems are multi-pointed graphs.\<close>

record 's TS =
  init :: "'s set"
  trans :: "('s \<times> 's) set"

text \<open>The inductive set of reachable states.\<close>

inductive_set
  reach ::  "('s, 'a) TS_scheme \<Rightarrow> 's set"
  for T :: "('s, 'a) TS_scheme"
where
  r_init [intro]:  "s \<in> init T \<Longrightarrow> s \<in> reach T"
| r_trans [intro]: "\<lbrakk> (s, t) \<in> trans T; s \<in> reach T \<rbrakk> \<Longrightarrow> t \<in> reach T"

(* inductive_cases reach_invert: "t \<in> reach T" *)

subsubsection \<open>Finite behaviours\<close>
(******************************************************************************)

text \<open>Note that behaviours grow at the head of the list, i.e., the initial
state is at the end.\<close>

inductive_set
  beh :: "('s, 'a) TS_scheme \<Rightarrow> ('s list) set"
  for T :: "('s, 'a) TS_scheme"
where
  b_empty [iff]: "[] \<in> beh T"
| b_init [intro]: "s \<in> init T \<Longrightarrow> [s] \<in> beh T"
| b_trans [intro]: "\<lbrakk> s # b \<in> beh T; (s, t) \<in> trans T \<rbrakk> \<Longrightarrow> t # s # b \<in> beh T"

inductive_cases beh_non_empty: "s # b \<in> beh T"

text \<open>Behaviours are prefix closed.\<close>

lemma beh_immediate_prefix_closed:
  "s # b \<in> beh T \<Longrightarrow> b \<in> beh T"
by (erule beh_non_empty, auto)

lemma beh_prefix_closed:
  "c @ b \<in> beh T \<Longrightarrow> b \<in> beh T"
by (induct c, auto dest!: beh_immediate_prefix_closed)

text \<open>States in behaviours are exactly reachable.\<close>

lemma reach_equiv_beh_states: "reach T = (\<Union>b\<in>beh T. set b)"
by (auto intro!: reach_in_beh beh_in_reach)

text \<open>Consecutive states in a behavior are connected by the transition relation\<close>

lemma beh_consecutive_in_trans:
  assumes "b \<in> beh TS"
  and "Suc i < length b"
  and "s = b ! Suc i"
  and "t = b ! i"
  shows "(s, t) \<in> trans TS"
proof-
  from assms have
    "b = take i b @ t # s # drop (Suc (Suc i)) b"
    by(auto simp add: id_take_nth_drop Cons_nth_drop_Suc)
  thus ?thesis
    by (metis assms(1) beh_non_empty beh_prefix_closed list.distinct(1) list.inject)
qed

subsubsection \<open>Specifications, observability, and implementation\<close>
(******************************************************************************)

text \<open>Specifications add an observer function to transition systems.\<close>

record ('s, 'o) spec = "'s TS" +
  obs :: "'s \<Rightarrow> 'o"

lemma beh_obs_upd [simp]: "beh (S(| obs := x |)) = beh S"
by (safe) (erule beh.induct, auto)+

lemma reach_obs_upd [simp]: "reach (S(| obs := x |)) = reach S"
by (safe) (erule reach.induct, auto)+

text \<open>Observable behaviour and reachability.\<close>

definition
  obeh :: "('s, 'o) spec \<Rightarrow> ('o list) set" where
  "obeh S \<equiv> (map (obs S))`(beh S)"

definition
  oreach :: "('s, 'o) spec \<Rightarrow> 'o set" where
  "oreach S \<equiv> (obs S)`(reach S)"

lemma oreach_equiv_obeh_states: "oreach S = (\<Union>b\<in>obeh S. set b)"
by (auto simp add: reach_equiv_beh_states oreach_def obeh_def)

lemma obeh_pi_translation:
  "(map pi)`(obeh S) = obeh (S(| obs := pi o (obs S) |))"
  by (simp add: obeh_def image_comp)

lemma oreach_pi_translation:
  "pi`(oreach S) = oreach (S(| obs := pi o (obs S) |))"
by (auto simp add: oreach_def)

text \<open>A predicate $P$ on the states of a specification is \emph{observable}
if it cannot distinguish between states yielding the same observation.
Equivalently, $P$ is observable if it is the inverse image under the
observation function of a predicate on observations.\<close>

definition
  observable :: "['s \<Rightarrow> 'o, 's set] \<Rightarrow> bool"
where
  "observable ob P \<equiv> \<forall>s s'. ob s = ob s' \<longrightarrow> s' \<in> P \<longrightarrow> s \<in> P"

definition
  observable2 :: "['s \<Rightarrow> 'o, 's set] \<Rightarrow> bool"
where
  "observable2 ob P \<equiv> \<exists>Q. P = ob-`Q"

definition
  observable3 :: "['s \<Rightarrow> 'o, 's set] \<Rightarrow> bool"
where
  "observable3 ob P \<equiv> ob-`ob`P \<subseteq> P"    \<comment> \<open>other direction holds trivially\<close>

lemma observableE [elim]:
  "\<lbrakk>observable ob P; ob s = ob s'; s' \<in> P\<rbrakk> \<Longrightarrow> s \<in> P"
by (unfold observable_def) (fast)

lemma observable2_equiv_observable: "observable2 ob P = observable ob P"
by (unfold observable_def observable2_def) (auto)

lemma observable3_equiv_observable2: "observable3 ob P = observable2 ob P"
by (unfold observable3_def observable2_def) (auto)

lemma observable_id [simp]: "observable id P"
by (simp add: observable_def)

text \<open>The set extension of a function @{term "ob"} is the left adjoint of
a Galois connection on the powerset lattices over domain and range of @{term "ob"}
where the right adjoint is the inverse image function.\<close>

declare image_vimage_subset [simp, intro]
declare vimage_image_subset [simp, intro]

text \<open>Similar but "reversed" (wrt to adjointness) relationships only hold under
additional conditions.\<close>

lemma image_r_vimage_l: "\<lbrakk> Q \<subseteq> ob`P; observable ob P \<rbrakk> \<Longrightarrow> ob-`Q \<subseteq> P"
by (auto)

lemma vimage_l_image_r: "\<lbrakk> ob-`Q \<subseteq> P; Q \<subseteq> range ob \<rbrakk> \<Longrightarrow> Q \<subseteq> ob`P"
by (drule image_mono [where f=ob], auto)

text \<open>Internal and external invariants\<close>

lemma external_from_internal_invariant:
  "\<lbrakk> reach S \<subseteq> P; (obs S)`P \<subseteq> Q \<rbrakk>
  \<Longrightarrow> oreach S \<subseteq> Q"
by (auto simp add: oreach_def)

lemma external_from_internal_invariant_vimage:
  "\<lbrakk> reach S \<subseteq> P; P \<subseteq> (obs S)-`Q \<rbrakk>
  \<Longrightarrow> oreach S \<subseteq> Q"
by (erule external_from_internal_invariant) (auto)

lemma external_to_internal_invariant_vimage:
  "\<lbrakk> oreach S \<subseteq> Q; (obs S)-`Q \<subseteq> P \<rbrakk>
  \<Longrightarrow> reach S \<subseteq> P"
by (auto simp add: oreach_def)

lemma external_to_internal_invariant:
  "\<lbrakk> oreach S \<subseteq> Q; Q \<subseteq> (obs S)`P; observable (obs S) P \<rbrakk>
  \<Longrightarrow> reach S \<subseteq> P"
by (erule external_to_internal_invariant_vimage) (auto)

lemma external_equiv_internal_invariant_vimage:
  "\<lbrakk> P = (obs S)-`Q \<rbrakk>
  \<Longrightarrow> (oreach S \<subseteq> Q) = (reach S \<subseteq> P)"
by (fast intro: external_from_internal_invariant_vimage
                external_to_internal_invariant_vimage
         del: subsetI)

lemma external_equiv_internal_invariant:
  "\<lbrakk> (obs S)`P = Q; observable (obs S) P \<rbrakk>
  \<Longrightarrow> (oreach S \<subseteq> Q) = (reach S \<subseteq> P)"
by (rule external_equiv_internal_invariant_vimage) (auto)

text \<open>Our notion of implementation is inclusion of observable behaviours.\<close>

definition
  implements :: "['p \<Rightarrow> 'o, ('s, 'o) spec, ('t, 'p) spec] \<Rightarrow> bool" where
  "implements pi Sa Sc \<equiv> (map pi)`(obeh Sc) \<subseteq> obeh Sa"

text \<open>Reflexivity and transitivity\<close>

lemma implements_refl: "implements id S S"
by (auto simp add: implements_def)

lemma implements_trans:
  "\<lbrakk> implements pi1 S1 S2; implements pi2 S2 S3 \<rbrakk>
  \<Longrightarrow> implements (pi1 o pi2) S1 S3"
by (auto simp add: implements_def image_comp del: subsetI
         dest: image_mono [where f="map pi1"])

text \<open>Preservation of external invariants\<close>

lemma implements_oreach:
  "implements pi Sa Sc \<Longrightarrow> pi`(oreach Sc) \<subseteq> oreach Sa"
by (auto simp add: implements_def oreach_equiv_obeh_states dest!: subsetD)

lemma external_invariant_preservation:
  "\<lbrakk> oreach Sa \<subseteq> Q; implements pi Sa Sc \<rbrakk>
  \<Longrightarrow> pi`(oreach Sc) \<subseteq> Q"
by (rule subset_trans [OF implements_oreach]) (auto)

lemma external_invariant_translation:
  "\<lbrakk> oreach Sa \<subseteq> Q; pi-`Q \<subseteq> P; implements pi Sa Sc \<rbrakk>
  \<Longrightarrow> oreach Sc \<subseteq> P"
apply (rule subset_trans [OF vimage_image_subset, of pi])
apply (rule subset_trans [where B="pi-`Q"])
apply (intro vimage_mono external_invariant_preservation, auto)
done

text \<open>Preservation of internal invariants\<close>

lemma internal_invariant_translation:
  "\<lbrakk> reach Sa \<subseteq> Pa; Pa \<subseteq> obs Sa -` Qa; pi -` Qa \<subseteq> Q; obs S -` Q \<subseteq> P;
     implements pi Sa S \<rbrakk>
  \<Longrightarrow> reach S \<subseteq> P"
by (rule external_from_internal_invariant_vimage [
      THEN external_invariant_translation,
      THEN external_to_internal_invariant_vimage])
   (assumption+)

(******************************************************************************)
subsection \<open>Invariants\<close>
(******************************************************************************)

text \<open>First we define Hoare triples over transition relations and then
we derive proof rules to establish invariants.\<close>

subsubsection \<open>Hoare triples\<close>
(******************************************************************************)

definition
  PO_hoare :: "['s set, ('s \<times> 's) set, 's set] \<Rightarrow> bool"
     ("(3{_} _ {> _})" [0, 0, 0] 90)
where
  "{pre} R {> post} \<equiv> R``pre \<subseteq> post"

lemmas PO_hoare_defs = PO_hoare_def Image_def

lemma "{P} R {> Q} = (\<forall>s t. s \<in> P \<longrightarrow> (s, t) \<in> R \<longrightarrow> t \<in> Q)"
by (auto simp add: PO_hoare_defs)

lemma hoareD:
  "\<lbrakk> {I} R {>J}; s \<in> I; (s, s') \<in> R \<rbrakk> \<Longrightarrow> s' \<in> J"
  by(auto simp add: PO_hoare_def)

text \<open>Some essential facts about Hoare triples.\<close>

lemma hoare_conseq_left [intro]:
  "\<lbrakk> {P'} R {> Q}; P \<subseteq> P' \<rbrakk>
  \<Longrightarrow> {P} R {> Q}"
by (auto simp add: PO_hoare_defs)

lemma hoare_conseq_right:
  "\<lbrakk> {P} R {> Q'}; Q' \<subseteq> Q \<rbrakk>
  \<Longrightarrow> {P} R {> Q}"
by (auto simp add: PO_hoare_defs)

lemma hoare_false_left [simp]:
  "{{}} R {> Q}"
by (auto simp add: PO_hoare_defs)

lemma hoare_true_right [simp]:
  "{P} R {> UNIV}"
by (auto simp add: PO_hoare_defs)

lemma hoare_conj_right [intro!]:
  "\<lbrakk> {P} R {> Q1}; {P} R {> Q2} \<rbrakk>
  \<Longrightarrow> {P} R {> Q1 \<inter> Q2}"
by (auto simp add: PO_hoare_defs)

text \<open>Special transition relations.\<close>

lemma hoare_stop [simp, intro!]:
  "{P} {} {> Q}"
by (auto simp add: PO_hoare_defs)

lemma hoare_skip [simp, intro!]:
  "P \<subseteq> Q \<Longrightarrow> {P} Id {> Q}"
by (auto simp add: PO_hoare_defs)

lemma hoare_trans_Un [iff]:
  "{P} R1 \<union> R2 {> Q} = ({P} R1 {> Q} \<and> {P} R2 {> Q})"
by (auto simp add: PO_hoare_defs)

lemma hoare_trans_UN [iff]:
  "{P} \<Union> x. R x {> Q} = (\<forall>x. {P} R x {> Q})"
by (auto simp add: PO_hoare_defs)

subsubsection \<open>Characterization of reachability\<close>
(******************************************************************************)

lemma reach_init: "reach T \<subseteq> I \<Longrightarrow> init T \<subseteq> I"
by (auto dest: subsetD)

lemma reach_trans: "reach T \<subseteq> I \<Longrightarrow> {reach T} trans T {> I}"
by (auto simp add: PO_hoare_defs)

text \<open>Useful consequences.\<close>

corollary init_reach [iff]: "init T \<subseteq> reach T"
by (rule reach_init, simp)

corollary trans_reach [iff]: "{reach T} trans T {> reach T}"
by (rule reach_trans, simp)

subsubsection \<open>Invariant proof rules\<close>
(******************************************************************************)

text \<open>Basic proof rule for invariants.\<close>

lemma inv_rule_basic:
  "\<lbrakk> init T \<subseteq> P; {P} (trans T) {> P} \<rbrakk>
  \<Longrightarrow> reach T \<subseteq> P"
by (safe, erule reach.induct, auto simp add: PO_hoare_def)

text \<open>General invariant proof rule. This rule is complete (set
@{term "I = reach T"}).\<close>

lemma inv_rule:
  "\<lbrakk> init T \<subseteq> I; I \<subseteq> P; {I} (trans T) {> I} \<rbrakk>
  \<Longrightarrow> reach T \<subseteq> P"
apply (rule subset_trans, auto)              \<comment> \<open>strengthen goal\<close>
apply (erule reach.induct, auto simp add: PO_hoare_def)
done

text \<open>The following rule is equivalent to the previous one.\<close>

lemma INV_rule:
  "\<lbrakk> init T \<subseteq> I; {I \<inter> reach T} (trans T) {> I} \<rbrakk>
  \<Longrightarrow> reach T \<subseteq> I"
by (safe, erule reach.induct, auto simp add: PO_hoare_defs)

text \<open>Proof of equivalence.\<close>

lemma inv_rule_from_INV_rule:
  "\<lbrakk> init T \<subseteq> I; I \<subseteq> P; {I} (trans T) {> I} \<rbrakk>
  \<Longrightarrow> reach T \<subseteq> P"
apply (rule subset_trans, auto del: subsetI)
apply (rule INV_rule, auto)
done

lemma INV_rule_from_inv_rule:
  "\<lbrakk> init T \<subseteq> I; {I \<inter> reach T} (trans T) {> I} \<rbrakk>
  \<Longrightarrow> reach T \<subseteq> I"
by (rule_tac I="I \<inter> reach T" in inv_rule, auto)

text \<open>Incremental proof rule for invariants using auxiliary invariant(s).
This rule might have become obsolete by addition of $INV\_rule$.\<close>

lemma inv_rule_incr:
  "\<lbrakk> init T \<subseteq> I; {I \<inter> J} (trans T) {> I}; reach T \<subseteq> J \<rbrakk>
  \<Longrightarrow> reach T \<subseteq> I"
by (rule INV_rule, auto)

(******************************************************************************)
subsection \<open>Refinement\<close>
(******************************************************************************)

text \<open>Our notion of refinement is simulation. We first define a general
notion of relational Hoare tuple, which we then use to define the refinement
proof obligation.  Finally, we show that observation-consistent refinement
of specifications implies the implementation relation between them.\<close>

subsubsection \<open>Relational Hoare tuples\<close>
(******************************************************************************)

text \<open>Relational Hoare tuples formalize the following generalized simulation
diagram:

\begin{verbatim}
                           o -- Ra --> o
                           |           |
                          pre         post
                           |           |
                           v           V
                           o -- Rc --> o
\end{verbatim}

Here, $Ra$ and $Rc$ are the abstract and concrete transition relations,
and $pre$ and $post$ are the pre- and post-relations.
(In the definiton below, the operator @{term "(O)"} stands for relational
composition, which is defined as follows: @{thm relcomp_def [no_vars]}.)\<close>

definition
  PO_rhoare ::
    "[('s \<times> 't) set, ('s \<times> 's) set, ('t \<times> 't) set, ('s \<times> 't) set] \<Rightarrow> bool"
     ("(4{_} _, _ {> _})" [0, 0, 0] 90)
where
  "{pre} Ra, Rc {> post} \<equiv> pre O Rc \<subseteq> Ra O post"

lemmas PO_rhoare_defs = PO_rhoare_def relcomp_unfold

text \<open>Facts about relational Hoare tuples.\<close>

lemma relhoare_conseq_left [intro]:
  "\<lbrakk> {pre'} Ra, Rc {> post}; pre \<subseteq> pre' \<rbrakk>
  \<Longrightarrow> {pre} Ra, Rc {> post}"
by (auto simp add: PO_rhoare_defs dest!: subsetD)

lemma relhoare_conseq_right:                    \<comment> \<open>do NOT declare [intro]\<close>
  "\<lbrakk> {pre} Ra, Rc {> post'}; post' \<subseteq> post \<rbrakk>
  \<Longrightarrow> {pre} Ra, Rc {> post}"
by (auto simp add: PO_rhoare_defs)

lemma relhoare_false_left [simp]:               \<comment> \<open>do NOT declare [intro]\<close>
  "{ {} } Ra, Rc {> post}"
by (auto simp add: PO_rhoare_defs)

lemma relhoare_true_right [simp]:                \<comment> \<open>not true in general\<close>
  "{pre} Ra, Rc {> UNIV} = (Domain (pre O Rc) \<subseteq> Domain Ra)"
by (auto simp add: PO_rhoare_defs)

lemma Domain_rel_comp [intro]:
  "Domain pre \<subseteq> R \<Longrightarrow> Domain (pre O Rc) \<subseteq> R"
by (auto simp add: Domain_def)

lemma rel_hoare_skip [iff]: "{R} Id, Id {> R}"
by (auto simp add: PO_rhoare_def)

text \<open>Reflexivity and transitivity.\<close>

lemma relhoare_refl [simp]: "{Id} R, R {> Id}"
by (auto simp add: PO_rhoare_defs)

lemma rhoare_trans:
  "\<lbrakk> {R1} T1, T2 {> R1}; {R2} T2, T3 {> R2} \<rbrakk>
  \<Longrightarrow> {R1 O R2} T1, T3 {> R1 O R2}"
apply (auto simp add: PO_rhoare_def del: subsetI)
apply (drule subset_refl [THEN relcomp_mono, where r=R1])
apply (drule subset_refl [THEN [2] relcomp_mono, where s=R2])
apply (auto simp add: O_assoc del: subsetI)
done

text \<open>Conjunction in the post-relation cannot be split in general.  However,
here are two useful special cases.  In the first case the abstract transtition
relation is deterministic and in the second case one conjunct is a cartesian
product of two state predicates.\<close>

lemma relhoare_conj_right_det:
  "\<lbrakk> {pre} Ra, Rc {> post1}; {pre} Ra, Rc {> post2};
     single_valued Ra \<rbrakk>                           \<comment> \<open>only for deterministic \<open>Ra\<close>!\<close>
  \<Longrightarrow> {pre} Ra, Rc {> post1 \<inter> post2}"
by (auto simp add: PO_rhoare_defs dest: single_valuedD dest!: subsetD)

lemma relhoare_conj_right_cartesian [intro]:
  "\<lbrakk> {Domain pre} Ra {> I}; {Range pre} Rc {> J};
     {pre} Ra, Rc {> post} \<rbrakk>
  \<Longrightarrow> {pre} Ra, Rc {> post \<inter> I \<times> J}"
by (force simp add: PO_rhoare_defs PO_hoare_defs Domain_def Range_def)

text \<open>Separate rule for cartesian products.\<close>

corollary relhoare_cartesian:
  "\<lbrakk> {Domain pre} Ra {> I}; {Range pre} Rc {> J};
     {pre} Ra, Rc {> post} \<rbrakk>                      \<comment> \<open>any \<open>post\<close>, including \<open>UNIV\<close>!\<close>
  \<Longrightarrow> {pre} Ra, Rc {> I \<times> J}"
by (auto intro: relhoare_conseq_right)

text \<open>Unions of transition relations.\<close>

lemma relhoare_concrete_Un [simp]:
  "{pre} Ra, Rc1 \<union> Rc2 {> post}
   = ({pre} Ra, Rc1 {> post} \<and> {pre} Ra, Rc2 {> post})"
apply (auto simp add: PO_rhoare_defs)
apply (auto dest!: subsetD)
done

lemma relhoare_concrete_UN [simp]:
  "{pre} Ra, \<Union>x. Rc x {> post} = (\<forall>x. {pre} Ra, Rc x {> post})"
apply (auto simp add: PO_rhoare_defs)
 apply (auto dest!: subsetD)
done

lemma relhoare_abstract_Un_left [intro]:
  "\<lbrakk> {pre} Ra1, Rc {> post} \<rbrakk>
  \<Longrightarrow> {pre} Ra1 \<union> Ra2, Rc {> post}"
by (auto simp add: PO_rhoare_defs)

lemma relhoare_abstract_Un_right [intro]:
  "\<lbrakk> {pre} Ra2, Rc {> post} \<rbrakk>
  \<Longrightarrow> {pre} Ra1 \<union> Ra2, Rc {> post}"
by (auto simp add: PO_rhoare_defs)

lemma relhoare_abstract_UN [intro!]:   \<comment> \<open>might be too aggressive?\<close>
  "\<lbrakk> {pre} Ra x, Rc {> post} \<rbrakk>
  \<Longrightarrow> {pre} \<Union>x. Ra x, Rc {> post}"
apply (auto simp add: PO_rhoare_defs)
apply (auto dest!: subsetD)
done

subsubsection \<open>Refinement proof obligations\<close>
(******************************************************************************)

text \<open>A transition system refines another one if the initial states and the
transitions are refined.
Initial state refinement means that for each concrete initial state there is
a related abstract one. Transition refinement means that the simulation
relation is preserved (as expressed by a relational Hoare tuple).
\<close>

definition
  PO_refines ::
    "[('s \<times> 't) set, ('s, 'a) TS_scheme, ('t, 'b) TS_scheme] \<Rightarrow> bool"
where
  "PO_refines R Ta Tc \<equiv> (
       init Tc \<subseteq> R``(init Ta)
     \<and> {R} (trans Ta), (trans Tc) {> R}
  )"

text \<open>Basic refinement rule. This is just an introduction rule for the
definition.\<close>

lemma refine_basic:
  "\<lbrakk> init Tc \<subseteq> R``(init Ta); {R} (trans Ta), (trans Tc) {> R} \<rbrakk>
  \<Longrightarrow> PO_refines R Ta Tc"
by (simp add: PO_refines_def)

text \<open>The following proof rule uses individual invariants @{term "I"}
and @{term "J"} of the concrete and abstract systems to strengthen the
simulation relation $R$.

The hypotheses state that these state predicates are indeed invariants.
Note that the pre-condition of the invariant preservation hypotheses for
@{term "I"} and @{term "J"} are strengthened by adding the predicates
@{term "Domain (R \<inter> UNIV \<times> J)"} and @{term "Range (R \<inter> I \<times> UNIV)"},
respectively.  In particular, the latter predicate may be essential, if a
concrete invariant depends on the simulation relation and an abstract invariant,
i.e. to "transport" abstract invariants to the concrete system.\<close>

lemma refine_init_using_invariants:
  "\<lbrakk> init Tc \<subseteq> R``(init Ta); init Ta \<subseteq> I; init Tc \<subseteq> J \<rbrakk>
  \<Longrightarrow> init Tc \<subseteq> (R \<inter> I \<times> J)``(init Ta)"
by (auto simp add: Image_def dest!: bspec subsetD)

lemma refine_trans_using_invariants:
  "\<lbrakk> {R \<inter> I \<times> J} (trans Ta), (trans Tc) {> R};
     {I \<inter> Domain (R \<inter> UNIV \<times> J)} (trans Ta) {> I};
     {J \<inter> Range (R \<inter> I \<times> UNIV)} (trans Tc) {> J} \<rbrakk>
  \<Longrightarrow> {R \<inter> I \<times> J} (trans Ta), (trans Tc) {> R  \<inter> I \<times> J}"
by (rule relhoare_conj_right_cartesian) (auto)

text \<open>This is our main rule for refinements.\<close>

lemma refine_using_invariants:
  "\<lbrakk> {R \<inter> I \<times> J} (trans Ta), (trans Tc) {> R};
     {I \<inter> Domain (R \<inter> UNIV \<times> J)} (trans Ta) {> I};
     {J \<inter> Range (R \<inter> I \<times> UNIV)} (trans Tc) {> J};
     init Tc \<subseteq> R``(init Ta);
     init Ta \<subseteq> I; init Tc \<subseteq> J \<rbrakk>
  \<Longrightarrow> PO_refines (R \<inter> I \<times> J) Ta Tc"
by (unfold PO_refines_def)
   (intro refine_init_using_invariants refine_trans_using_invariants conjI)

subsubsection \<open>Deriving invariants from refinements\<close>
(******************************************************************************)

text \<open>Some invariants can only be proved after the simulation has been
established, because they depend on the simulation relation and some abstract
invariants.  Here is a rule to derive invariant theorems from the refinement.\<close>

lemma PO_refines_implies_Range_trans:
  "PO_refines R Ta Tc \<Longrightarrow> {Range R} trans Tc {> Range R}"
by (auto simp add: PO_refines_def PO_rhoare_def PO_hoare_def)

lemma PO_refines_implies_Range_invariant:
  "PO_refines R Ta Tc \<Longrightarrow> reach Tc \<subseteq> Range R"
by (rule INV_rule)
   (auto intro!: PO_refines_implies_Range_init
                 PO_refines_implies_Range_trans)

text \<open>The following rules are more useful in proofs.\<close>

corollary INV_init_from_refinement:
  "\<lbrakk> PO_refines R Ta Tc; Range R \<subseteq> I \<rbrakk>
  \<Longrightarrow> init Tc \<subseteq> I"
by (drule PO_refines_implies_Range_init, auto)

corollary INV_trans_from_refinement:
  "\<lbrakk> PO_refines R Ta Tc; K \<subseteq> Range R; Range R \<subseteq> I \<rbrakk>
  \<Longrightarrow> {K} trans Tc {> I}"
apply (drule PO_refines_implies_Range_trans)
apply (auto intro: hoare_conseq_right)
done

corollary INV_from_refinement:
  "\<lbrakk> PO_refines R Ta Tc; Range R \<subseteq> I \<rbrakk>
  \<Longrightarrow> reach Tc \<subseteq> I"
by (drule PO_refines_implies_Range_invariant, fast)

subsubsection \<open>Transfering abstract invariants to concrete systems\<close>
(******************************************************************************)

lemmas hoare_conseq = hoare_conseq_right[OF hoare_conseq_left] for P' R Q'

lemma PO_refines_implies_R_image_init:
  "PO_refines R Ta Tc \<Longrightarrow> init Tc \<subseteq> R `` (init Ta)"
  apply(rule subset_trans[where B="R `` init Ta"])
   apply (auto simp add: PO_refines_def)
  done

lemma commute_dest:
  "\<lbrakk> R O Tc \<subseteq> Ta O R; (sa, sc) \<in> R; (sc, sc') \<in> Tc \<rbrakk> \<Longrightarrow> \<exists>sa'. (sa, sa') \<in> Ta \<and> (sa', sc') \<in> R"
  by(auto)

lemma PO_refines_implies_R_image_trans:
  assumes "PO_refines R Ta Tc"
  shows "{R `` reach Ta} trans Tc {> R `` reach Ta}" using assms
proof(unfold PO_hoare_def Image_def PO_refines_def PO_rhoare_def, safe)
  fix sc sc' sa
  assume R: "(sa, sc) \<in> R"
    and step: "(sc, sc') \<in> TS.trans Tc"
    and sa_reach: "sa \<in> reach Ta"
    and trans_ref: "R O trans Tc \<subseteq> trans Ta O R"
  from commute_dest[OF trans_ref R step] sa_reach
  show " \<exists>sa'\<in>reach Ta. (sa', sc') \<in> R"
    by(auto)
qed

lemma PO_refines_implies_R_image_invariant:
  assumes "PO_refines R Ta Tc"
  shows "reach Tc \<subseteq> R `` reach Ta"
proof(rule INV_rule)
  show "init Tc \<subseteq> R `` reach Ta"
    by (rule subset_trans[OF PO_refines_implies_R_image_init, OF assms]) (auto)
next
  show "{R `` reach Ta \<inter> reach Tc} TS.trans Tc {> R `` reach Ta}" using assms
    by (auto intro!: PO_refines_implies_R_image_trans)
qed

lemma abs_INV_trans_transfer:
  assumes
    ref: "PO_refines R Ta Tc"
    and abs_hoare: "{I} trans Ta {> J}"
  shows "{R `` I} trans Tc {> R `` J}"
proof(unfold PO_hoare_def Image_def, safe)
  fix sc sc' sa
  assume step: "(sc, sc') \<in> trans Tc" and abs_inv: "sa \<in> I" and R: "(sa, sc) \<in> R"
  from ref step and R obtain sa' where
    abs_step: "(sa, sa') \<in> trans Ta" and R': "(sa', sc') \<in> R"
    by(auto simp add: PO_refines_def PO_rhoare_def)
  with hoareD[OF abs_hoare abs_inv abs_step]
  show "\<exists>sa'\<in>J. (sa', sc') \<in> R"
    by(blast)
qed

lemma abs_INV_transfer:
  assumes
    "PO_refines R Ta Tc"
    "reach Ta \<subseteq> I"
  shows "reach Tc \<subseteq> R `` I" using PO_refines_implies_R_image_invariant[OF assms(1)] assms(2)
  by(auto)

subsubsection \<open>Refinement of specifications\<close>
(******************************************************************************)

text \<open>Lift relation membership to finite sequences\<close>

inductive_set
  seq_lift :: "('s \<times> 't) set \<Rightarrow> ('s list \<times> 't list) set"
  for R :: "('s \<times> 't) set"
where
  sl_nil [iff]: "([], []) \<in> seq_lift R"
| sl_cons [intro]:
    "\<lbrakk> (xs, ys) \<in> seq_lift R; (x, y) \<in> R \<rbrakk> \<Longrightarrow> (x#xs, y#ys) \<in> seq_lift R"

inductive_cases sl_cons_right_invert: "(ba', t # bc) \<in> seq_lift R"

text \<open>For each concrete behaviour there is a related abstract one.\<close>

lemma behaviour_refinement:
assumes "PO_refines R Ta Tc" "bc \<in> beh Tc"
shows "\<exists>ba \<in> beh Ta. (ba, bc) \<in> seq_lift R"
using assms(2)
proof (induct rule: beh.induct)
  case b_empty thus ?case by auto
next
  case (b_init s) thus ?case using assms(1) by (auto simp add: PO_refines_def)
next
  case (b_trans s b s') show ?case
  proof -
    from b_trans(2) obtain t c where "t # c \<in> beh Ta" "(t, s) \<in> R" "(t # c, s # b) \<in> seq_lift R"
      by (auto elim!: sl_cons_right_invert)
    moreover
    from \<open>(t, s) \<in> R\<close> \<open>(s, s') \<in> TS.trans Tc\<close> assms(1)
    obtain t' where "(t, t') \<in> trans Ta" "(t', s') \<in> R"
      by (auto simp add: PO_refines_def PO_rhoare_def)
    ultimately
    have "t' # t # c \<in> beh Ta" "(t' # t # c, s' # s # b) \<in> seq_lift R" by auto
    thus ?thesis by (auto)
  qed
qed

text \<open>Observation consistency of a relation is defined using a mediator
function @{term "pi"} to abstract the concrete observation.  This allows us
to also refine the observables as we move down a refinement branch.
\<close>

definition
  obs_consistent ::
    "[('s \<times> 't) set, 'p \<Rightarrow> 'o, ('s, 'o) spec, ('t, 'p) spec] \<Rightarrow> bool"
where
  "obs_consistent R pi Sa Sc \<equiv> (\<forall>s t. (s, t) \<in> R \<longrightarrow> pi (obs Sc t) = obs Sa s)"

lemma obs_consistent_refl [iff]: "obs_consistent Id id S S"
by (simp add: obs_consistent_def)

lemma obs_consistent_trans [intro]:
  "\<lbrakk> obs_consistent R1 pi1 S1 S2; obs_consistent R2 pi2 S2 S3 \<rbrakk>
  \<Longrightarrow> obs_consistent (R1 O R2) (pi1 o pi2) S1 S3"
by (auto simp add: obs_consistent_def)

lemma obs_consistent_empty: "obs_consistent {} pi Sa Sc"
by (auto simp add: obs_consistent_def)

lemma obs_consistent_conj2 [intro]:
  "obs_consistent R pi Sa Sc \<Longrightarrow> obs_consistent (R' \<inter> R) pi Sa Sc"
by (auto simp add: obs_consistent_def)

lemma obs_consistent_behaviours:
  "\<lbrakk> obs_consistent R pi Sa Sc; bc \<in> beh Sc; ba \<in> beh Sa; (ba, bc) \<in> seq_lift R\<rbrakk>
  \<Longrightarrow> map pi (map (obs Sc) bc) = map (obs Sa) ba"
by (erule seq_lift.induct) (auto simp add: obs_consistent_def)

text \<open>Definition of refinement proof obligations.\<close>

definition
  refines ::
    "[('s \<times> 't) set, 'p \<Rightarrow> 'o, ('s, 'o) spec, ('t, 'p) spec] \<Rightarrow> bool"
where
  "refines R pi Sa Sc \<equiv> obs_consistent R pi Sa Sc \<and> PO_refines R Sa Sc"

lemmas refines_defs =
  refines_def PO_refines_def

lemma refinesI:
  "\<lbrakk> PO_refines R Sa Sc; obs_consistent R pi Sa Sc \<rbrakk>
  \<Longrightarrow> refines R pi Sa Sc"
by (simp add: refines_def)

lemma PO_refines_from_refines:
  "refines R pi Sa Sc \<Longrightarrow> PO_refines R Sa Sc"
by (simp add: refines_def)

text \<open>Reflexivity and transitivity of refinement.\<close>

lemma refinement_reflexive: "refines Id id S S"
by (auto simp add: refines_defs)

lemma refinement_transitive:
  "\<lbrakk> refines R1 pi1 S1 S2; refines R2 pi2 S2 S3 \<rbrakk>
  \<Longrightarrow> refines (R1 O R2) (pi1 o pi2) S1 S3"
apply (auto simp add: refines_defs del: subsetI intro: rhoare_trans)
apply (fastforce dest: Image_mono)
done

text \<open>Soundness of refinement for proving implementation\<close>

lemma observable_behaviour_refinement:
  "\<lbrakk> refines R pi Sa Sc; bc \<in> obeh Sc \<rbrakk> \<Longrightarrow> map pi bc \<in> obeh Sa"
by (auto simp add: refines_def obeh_def image_def
         dest!: behaviour_refinement obs_consistent_behaviours)

theorem refinement_soundness:
  "refines R pi Sa Sc \<Longrightarrow> implements pi Sa Sc"
by (auto simp add: implements_def
         elim!: observable_behaviour_refinement)

text \<open>Extended versions of proof rules including observations\<close>

lemmas Refinement_basic = refine_basic [THEN refinesI]
lemmas Refinement_using_invariants = refine_using_invariants [THEN refinesI]

lemmas INV_init_from_Refinement =
  INV_init_from_refinement [OF PO_refines_from_refines]

lemmas INV_trans_from_Refinement =
  INV_trans_from_refinement [OF PO_refines_from_refines]

lemmas INV_from_Refinement =
  INV_from_refinement [OF PO_refines_from_refines]

end