(* Author: Tobias Nipkow *)

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

theory Tree234_Set
imports
  Tree234
  Cmp
  "../Data_Structures/Set_by_Ordered"
begin

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

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 del_min :: "'a tree234 \<Rightarrow> 'a * 'a up\<^sub>d" where
"del_min (Node2 Leaf a Leaf) = (a, Up\<^sub>d Leaf)" |
"del_min (Node3 Leaf a Leaf b Leaf) = (a, T\<^sub>d(Node2 Leaf b Leaf))" |
"del_min (Node4 Leaf a Leaf b Leaf c Leaf) = (a, T\<^sub>d(Node3 Leaf b Leaf c Leaf))" |
"del_min (Node2 l a r) = (let (x,l') = del_min l in (x, node21 l' a r))" |
"del_min (Node3 l a m b r) = (let (x,l') = del_min l in (x, node31 l' a m b r))" |
"del_min (Node4 l a m b n c r) = (let (x,l') = del_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) = del_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') = del_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') = del_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') = del_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') = del_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') = del_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 "sorted(inorder t) \<Longrightarrow> isin t x = (x \<in> elems (inorder t))"
by (induction t) (auto simp: elems_simps1 ball_Un)

lemma isin_set: "sorted(inorder t) \<Longrightarrow> isin t x = (x \<in> elems (inorder t))"
by (induction t) (auto simp: elems_simps2 split!: if_splits)

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 del_minD:
  "del_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: del_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 del_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{* First a standard proof that @{const ins} preserves @{const bal}. *}

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{* Now an alternative proof (by Brian Huffman) that runs faster because
two properties (balance and height) are combined in one predicate. *}

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 {* The @{const "insert"} function either preserves the height of the
tree, or increases it by one. The constructor returned by the @{term
"insert"} function determines which: A return value of the form @{term
"T\<^sub>i t"} indicates that the height will be the same. A value of the
form @{term "Up\<^sub>i l p r"} indicates an increase in height. *}

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 {* The @{const insert} operation preserves balance. *}

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_del_min:
  "del_min t = (x, t') \<Longrightarrow> height t > 0 \<Longrightarrow> bal t \<Longrightarrow> height t' = height t"
by(induct t arbitrary: x t' rule: del_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_del_min split!: if_split prod.split)

lemma bal_del_min:
  "\<lbrakk> del_min t = (x, t'); bal t; height t > 0 \<rbrakk> \<Longrightarrow> bal (tree\<^sub>d t')"
by(induct t arbitrary: x t' rule: del_min.induct)
  (auto simp: heights height_del_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_del_min height_del height_del_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 Set_by_Ordered
where empty = Leaf 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+

end


subsection \<open>SubNode Phase\<close>

theory SubPhase
  imports
    Common
    Proofs.StampEvalThms
begin

phase SubNode
  terminating size
begin

(* Word level proofs *)
lemma bin_sub_after_right_add:
  shows "((x::('a::len) word) + (y::('a::len) word)) - y = x"
  by simp

lemma sub_self_is_zero:
  shows "(x::('a::len) word) - x = 0"
  by simp

lemma bin_sub_then_left_add:
  shows "(x::('a::len) word) - (x + (y::('a::len) word)) = -y"
  by simp

lemma bin_sub_then_left_sub:
  shows "(x::('a::len) word) - (x - (y::('a::len) word)) = y"
  by simp

lemma bin_subtract_zero:
  shows "(x :: 'a::len word) - (0 :: 'a::len word) = x"
  by simp

lemma bin_sub_negative_value:
 "(x :: ('a::len) word) - (-(y :: ('a::len) word)) = x + y"
  by simp

lemma bin_sub_self_is_zero:
 "(x :: ('a::len) word) - x = 0"
  by simp

lemma bin_sub_negative_const:
"(x :: 'a::len word) - (-(y :: 'a::len word)) = x + y"
  by simp

(* Value level proofs *)
lemma val_sub_after_right_add_2:
  assumes "x = new_int b v"
  assumes "val[(x + y) - y] \<noteq> UndefVal"
  shows   "val[(x + y) - y] = val[x]"
  using bin_sub_after_right_add
  using assms apply (cases x; cases y; auto)
  by (metis (full_types) intval_sub.simps(2))

lemma val_sub_after_left_sub:
  assumes "val[(x - y) - x] \<noteq> UndefVal"
  shows   "val[(x - y) - x] = val[-y]"
  using assms apply (cases x; cases y; auto)
  using intval_sub.elims by fastforce

lemma val_sub_then_left_sub:
  assumes "y = new_int b v"
  assumes "val[x - (x - y)] \<noteq> UndefVal"
  shows   "val[x - (x - y)] = val[y]"
  using assms apply (cases x; cases y; auto)
  by (metis (mono_tags) intval_sub.simps(5))

lemma val_subtract_zero:
  assumes "x = new_int b v"
  assumes "intval_sub x (IntVal b 0) \<noteq> UndefVal "
  shows   "intval_sub x (IntVal b 0) = val[x]"
  using assms by (induction x; simp)

lemma val_zero_subtract_value:
  assumes "x = new_int b v"
  assumes "intval_sub (IntVal b 0) x \<noteq> UndefVal "
  shows   "intval_sub (IntVal b 0) x = val[-x]"
  using assms by (induction x; simp)

lemma val_sub_then_left_add:
  assumes "val[x - (x + y)] \<noteq> UndefVal"
  shows   "val[x - (x + y)] = val[-y]"
  using assms apply (cases x; cases y; auto)
  by (metis (mono_tags, lifting) intval_sub.simps(5))

lemma val_sub_negative_value:
  assumes "val[x - (-y)] \<noteq> UndefVal"
  shows   "val[x - (-y)] = val[x + y]"
  using assms by (cases x; cases y; auto)

lemma val_sub_self_is_zero:
  assumes "x = new_int b v \<and> val[x - x] \<noteq> UndefVal"
  shows   "val[x - x] = new_int b 0"
  using assms by (cases x; auto)

lemma val_sub_negative_const:
  assumes "y = new_int b v \<and> val[x - (-y)] \<noteq> UndefVal"
  shows "val[x - (-y)] = val[x + y]"
  using assms by (cases x; cases y; auto)

(* Exp level proofs *)
lemma exp_sub_after_right_add:
  shows "exp[(x + y) - y] \<ge> exp[x]"
   apply auto
  by (smt (verit) evalDet eval_unused_bits_zero intval_add.elims new_int.simps
      val_sub_after_right_add_2)

lemma exp_sub_after_right_add2:
  shows "exp[(x + y) - x] \<ge> exp[y]"
  using exp_sub_after_right_add apply auto
  by (smt (z3) Value.inject(1) diff_eq_eq evalDet eval_unused_bits_zero intval_add.elims
      intval_sub.elims new_int.simps new_int_bin.simps take_bit_dist_subL bin_eval.simps(1)
      bin_eval.simps(3) intval_add_sym unfold_binary)

lemma exp_sub_negative_value:
 "exp[x - (-y)] \<ge> exp[x + y]"
  apply simp
  by (smt (verit) bin_eval.simps(1) bin_eval.simps(3) evaltree_not_undef unary_eval.simps(2)
      unfold_binary unfold_unary val_sub_negative_value)

lemma exp_sub_then_left_sub:
  "exp[x - (x - y)] \<ge> exp[y]"
  using val_sub_then_left_sub apply auto
  subgoal premises p for m p xa xaa ya
    proof-
      obtain xa where xa: "[m, p] \<turnstile> x \<mapsto> xa"
        using p(2) by blast
      obtain ya where ya: "[m, p] \<turnstile> y \<mapsto> ya"
        using p(5) by auto
      obtain xaa where xaa: "[m, p] \<turnstile> x \<mapsto> xaa"
        using p(2) by blast
      have 1: "val[xa - (xaa - ya)] \<noteq> UndefVal"
        by (metis evalDet p(2) p(3) p(4) p(5) xa xaa ya)
      then have "val[xaa - ya] \<noteq> UndefVal"
        by auto
      then have "[m, p] \<turnstile> y \<mapsto> val[xa - (xaa - ya)]"
        by (metis "1" Value.exhaust evalDet eval_unused_bits_zero evaltree_not_undef
            intval_sub.simps(6) intval_sub.simps(7) new_int.simps p(5) val_sub_then_left_sub xa xaa
            ya)
      then show ?thesis
        by (metis evalDet p(2) p(4) p(5) xa xaa ya)
    qed
  done

thm_oracles exp_sub_then_left_sub

text \<open>Optimisations\<close>

optimization SubAfterAddRight: "((x + y) - y) \<longmapsto>  x"
  using exp_sub_after_right_add by blast

optimization SubAfterAddLeft: "((x + y) - x) \<longmapsto>  y"
  using exp_sub_after_right_add2 by blast

optimization SubAfterSubLeft: "((x - y) - x) \<longmapsto>  -y"
   apply (metis Suc_lessI add_2_eq_Suc' add_less_cancel_right less_trans_Suc not_add_less1
          size_binary_const size_binary_lhs size_binary_rhs size_non_add)
   apply auto
  by (metis evalDet unary_eval.simps(2) unfold_unary val_sub_after_left_sub)

optimization SubThenAddLeft: "(x - (x + y)) \<longmapsto> -y"
   apply auto
  by (metis evalDet unary_eval.simps(2) unfold_unary val_sub_then_left_add)

optimization SubThenAddRight: "(y - (x + y)) \<longmapsto> -x"
   apply auto
  by (metis evalDet intval_add_sym unary_eval.simps(2) unfold_unary val_sub_then_left_add)

optimization SubThenSubLeft: "(x - (x - y)) \<longmapsto> y"
  using size_simps apply simp
  using exp_sub_then_left_sub by blast

optimization SubtractZero: "(x - (const IntVal b 0)) \<longmapsto> x"
  apply auto
  by (smt (verit) add.right_neutral diff_add_cancel eval_unused_bits_zero intval_sub.elims
      intval_word.simps new_int.simps new_int_bin.simps)

thm_oracles SubtractZero

(* Doesn't have any subgoals? *)
(*
optimization SubNegativeConstant: "(x - (const (IntVal b y))) \<longmapsto>
                                    x + (const (IntVal b y))  when (y < 0)"
  done
*)

optimization SubNegativeValue: "(x - (-y)) \<longmapsto> x + y"
  apply (metis add_2_eq_Suc' less_SucI less_add_Suc1 not_less_eq size_binary_const size_non_add)
  using exp_sub_negative_value by simp

thm_oracles SubNegativeValue

lemma negate_idempotent:
  assumes "x = IntVal b v \<and> take_bit b v = v"
  shows "x = val[-(-x)]"
  using assms
  using is_IntVal_def by force

(*
lemma remove_sub_preserve_take_bit:
  fixes v :: "64 word"
  assumes "b > 0 \<and> b \<le> 64"
  assumes "take_bit b (-v) = -v"
  shows "take_bit b v = v"
  using assms sorry

value "-1::64 word"
value "take_bit 64 (-1)::64 word"
value "take_bit 64 (-(-1))::64 word"

(* if sign extend take bits of b v get back v *)

lemma valid_sub_const:
  assumes "y = IntVal b v \<and> b > 0"
  assumes "valid_value (val[-y]) (constantAsStamp (val[-y]))"
  shows "valid_value y (constantAsStamp y)"
  using assms apply (cases y; auto)
  apply (simp add: int_power_div_base signed_take_bit_int_greater_eq_minus_exp_word)
  apply (metis (no_types, opaque_lifting) One_nat_def Suc_diff_Suc Suc_le_lessD cancel_comm_monoid_add_class.diff_cancel diff_diff_cancel gr0_conv_Suc lessI less_imp_le_nat signed_take_bit_int_less_exp_word size64 size_word.rep_eq upper_bounds_equiv)
  apply (metis One_nat_def Suc_less_eq Suc_pred le_imp_less_Suc signed_take_bit_int_greater_eq_minus_exp_word size64 upper_bounds_equiv wsst_TYs(3))
  apply (metis One_nat_def Suc_le_lessD Suc_pred signed_take_bit_int_less_exp_word size64 upper_bounds_equiv wsst_TYs(3))
  using remove_sub_preserve_take_bit
  sorry
  (* (smt (verit) Groups.add_ac(2) One_nat_def Suc_diff_Suc Suc_less_eq Suc_pred add.inverse_inverse add_Suc_right bit_last_iff bit_take_bit_iff bot_nat_0.not_eq_extremum cancel_comm_monoid_add_class.diff_cancel diff_diff_cancel diff_zero gr0_conv_Suc int_signed_value.simps intval_word.simps len_gt_0 lessI less_imp_diff_less less_imp_le_nat less_numeral_extra(1) linorder_not_le mask_1 mask_eq_take_bit_minus_one nat.simps(1) nat.simps(3) neg_one.elims neg_one_signed neg_one_value new_int_take_bits not_less numeral.simps(2) numeral_eq_Suc numerals(2) one_le_numeral order_le_less order_trans plus_nat.simps(2) remove_sub_preserve_take_bit signed_take_bit_take_bit size64 take_bit_length_eq wsst_TYs(3) zero_le zero_le_numeral)
*)

lemma unnegated_rhs_evals:
  assumes "[m, p] \<turnstile> exp[const val[-y]] \<mapsto> v"
  shows "[m, p] \<turnstile> exp[const val[y]] \<mapsto> intval_negate v"
proof -
  obtain b vv where vv: "[m, p] \<turnstile> exp[const val[-y]] \<mapsto> IntVal b vv"
    using assms
    by (metis evaltree_not_undef intval_negate.elims new_int.elims unfold_const)
  then have "take_bit b vv = vv"
    by (simp add: eval_unused_bits_zero)
  then have "v = val[-(-v)]"
    using vv
    by (metis assms negate_idempotent unfold_const)
  then obtain yv where yv: "[m, p] \<turnstile> exp[const val[y]] \<mapsto> IntVal b yv"
    using vv apply auto using evaltree.ConstantExpr valid_sub_const
    by (metis Value.distinct(1) Value.inject(1) eval_bits_1_64 intval_negate.elims new_int.simps)
  then show ?thesis
    using assms apply auto
    using yv by fastforce
qed

optimization SubNegativeConstant: "x - (const (val[-y])) \<longmapsto> x + (const y)"
   defer
   apply simp apply ((rule allI)+; rule impI)
  subgoal premises eval for m p v
  proof -
    obtain xv where xv: "[m, p] \<turnstile> x \<mapsto> xv"
      using eval by auto
    obtain yv where yv: "[m, p] \<turnstile> exp[const (val[-y])] \<mapsto> intval_negate yv"
      using eval by auto
    obtain lhs where lhsdef: "[m, p] \<turnstile> exp[x - (const (val[-y]))] \<mapsto> lhs"
      using eval by auto
    then have lhs: "lhs = val[xv - (-yv)]"
      by (metis BinaryExprE bin_eval.simps(3) evalDet xv yv)
    obtain rhs where rhsdef: "[m, p] \<turnstile> exp[x + (const y)] \<mapsto> rhs"
      using eval unnegated_rhs_evals
      by (metis EvalTreeE(1) bin_eval.simps(1) bin_eval.simps(3) unfold_binary val_sub_negative_value)
    then have rhs: "rhs = val[xv + yv]"
      by (metis BinaryExprE EvalTreeE(1) bin_eval.simps(1) evalDet unnegated_rhs_evals xv yv)
    have "lhs = rhs"
      using val_sub_negative_value lhs rhs
      by (metis bin_eval.simps(3) eval evalDet unfold_binary xv yv)
    then show ?thesis
      by (metis eval evalDet lhsdef rhsdef)
  qed
  sorry
*)

(*Additional check for not constant for termination *)
optimization ZeroSubtractValue: "((const IntVal b 0) - x) \<longmapsto> (-x)
                                  when (wf_stamp x \<and> stamp_expr x = IntegerStamp b lo hi \<and> \<not>(is_ConstantExpr x))"
   defer
  apply auto unfolding wf_stamp_def
  apply (smt (verit) diff_0 intval_negate.simps(1) intval_sub.elims intval_word.simps
          new_int_bin.simps unary_eval.simps(2) unfold_unary)
  using add_2_eq_Suc' size.simps(2) size_flip_binary by presburger

(*
fun forPrimitive :: "Stamp \<Rightarrow> int64 \<Rightarrow> IRExpr" where
  "forPrimitive (IntegerStamp b lo hi) v = ConstantExpr (if take_bit b v = v then (IntVal b v) else UndefVal)" |
  "forPrimitive _ _ = ConstantExpr UndefVal"

lemma unfold_forPrimitive:
  "forPrimitive s v = ConstantExpr (if is_IntegerStamp s \<and> take_bit (stp_bits s) v = v then (IntVal (stp_bits s) v) else UndefVal)"
  by (cases s; auto)

lemma forPrimitive_size[size_simps]: "size (forPrimitive s v) = 1"
  by (cases s; auto)

lemma forPrimitive_eval:
  (*assumes "valid_value (IntVal b v) s"*)
  assumes "s = IntegerStamp b lo hi"
  assumes "take_bit b v = v"
  shows "[m, p] \<turnstile> forPrimitive s v \<mapsto> (IntVal b v)"
  unfolding unfold_forPrimitive using assms apply auto
  apply (rule evaltree.ConstantExpr)
  sorry

lemma evalSubStamp:
  assumes "[m, p] \<turnstile> exp[x - y] \<mapsto> v"
  assumes "wf_stamp exp[x - y]"
  shows "\<exists>b lo hi. stamp_expr exp[x - y] = IntegerStamp b lo hi"
proof -
  have "valid_value v (stamp_expr exp[x - y])"
    using assms unfolding wf_stamp_def by auto
  then have "stamp_expr exp[x - y] \<noteq> IllegalStamp"
    by force
  then show ?thesis
    unfolding stamp_expr.simps using stamp_binary.simps
    by (smt (z3) stamp_binary.elims unrestricted_stamp.simps(2))
qed

lemma evalSubArgsStamp:
  assumes "[m, p] \<turnstile> exp[x - y] \<mapsto> v"
  assumes "\<exists>lo hi. stamp_expr exp[x - y] = IntegerStamp b lo hi"
  shows "\<exists>lo hi. stamp_expr exp[x] = IntegerStamp b lo hi"
  using assms sorry

optimization SubSelfIsZero: "(x - x) \<longmapsto> forPrimitive (stamp_expr exp[x - x]) 0 when ((wf_stamp x) \<and> (wf_stamp exp[x - x]))"
  using size_non_const apply fastforce
   apply simp apply (rule impI; (rule allI)+; rule impI)
  subgoal premises eval for m p v
  proof -
    obtain b where "\<exists>lo hi. stamp_expr exp[x - x] = IntegerStamp b lo hi"
    using evalSubStamp eval
    by meson
  then show ?thesis sorry
qed
  done
*)

optimization SubSelfIsZero: "(x - x) \<longmapsto> const IntVal b 0 when
                      (wf_stamp x \<and> stamp_expr x = IntegerStamp b lo hi)"
   apply simp_all
   apply auto
  using IRExpr.disc(42) One_nat_def size_non_const apply presburger
  by (smt (verit, best) wf_value_def ConstantExpr evalDet eval_bits_1_64 eval_unused_bits_zero
      new_int.simps take_bit_of_0 val_sub_self_is_zero validDefIntConst valid_int wf_stamp_def)

end (* End of SubPhase *)

end (* End of file *)


(*  Title:      FOL/ex/Propositional_Int.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1991  University of Cambridge
*)

section {* First-Order Logic: propositional examples (intuitionistic version) *}

theory Propositional_Int
imports IFOL
begin

text {* commutative laws of @{text "&"} and @{text "|"} *}

lemma "P & Q  -->  Q & P"
  by (tactic "IntPr.fast_tac @{context} 1")

lemma "P | Q  -->  Q | P"
  by (tactic "IntPr.fast_tac @{context} 1")

text {* associative laws of @{text "&"} and @{text "|"} *}
lemma "(P & Q) & R  -->  P & (Q & R)"
  by (tactic "IntPr.fast_tac @{context} 1")

lemma "(P | Q) | R  -->  P | (Q | R)"
  by (tactic "IntPr.fast_tac @{context} 1")

text {* distributive laws of @{text "&"} and @{text "|"} *}
lemma "(P & Q) | R  --> (P | R) & (Q | R)"
  by (tactic "IntPr.fast_tac @{context} 1")

lemma "(P | R) & (Q | R)  --> (P & Q) | R"
  by (tactic "IntPr.fast_tac @{context} 1")

lemma "(P | Q) & R  --> (P & R) | (Q & R)"
  by (tactic "IntPr.fast_tac @{context} 1")

lemma "(P & R) | (Q & R)  --> (P | Q) & R"
  by (tactic "IntPr.fast_tac @{context} 1")

text {* Laws involving implication *}

lemma "(P-->R) & (Q-->R) <-> (P|Q --> R)"
  by (tactic "IntPr.fast_tac @{context} 1")

lemma "(P & Q --> R) <-> (P--> (Q-->R))"
  by (tactic "IntPr.fast_tac @{context} 1")

lemma "((P-->R)-->R) --> ((Q-->R)-->R) --> (P&Q-->R) --> R"
  by (tactic "IntPr.fast_tac @{context} 1")

lemma "~(P-->R) --> ~(Q-->R) --> ~(P&Q-->R)"
  by (tactic "IntPr.fast_tac @{context} 1")

lemma "(P --> Q & R) <-> (P-->Q)  &  (P-->R)"
  by (tactic "IntPr.fast_tac @{context} 1")

text {* Propositions-as-types *}

-- {* The combinator K *}
lemma "P --> (Q --> P)"
  by (tactic "IntPr.fast_tac @{context} 1")

-- {* The combinator S *}
lemma "(P-->Q-->R)  --> (P-->Q) --> (P-->R)"
  by (tactic "IntPr.fast_tac @{context} 1")

-- {* Converse is classical *}
lemma "(P-->Q) | (P-->R)  -->  (P --> Q | R)"
  by (tactic "IntPr.fast_tac @{context} 1")

lemma "(P-->Q)  -->  (~Q --> ~P)"
  by (tactic "IntPr.fast_tac @{context} 1")

text {* Schwichtenberg's examples (via T. Nipkow) *}

lemma stab_imp: "(((Q-->R)-->R)-->Q) --> (((P-->Q)-->R)-->R)-->P-->Q"
  by (tactic "IntPr.fast_tac @{context} 1")

lemma stab_to_peirce:
  "(((P --> R) --> R) --> P) --> (((Q --> R) --> R) --> Q)
                              --> ((P --> Q) --> P) --> P"
  by (tactic "IntPr.fast_tac @{context} 1")

lemma peirce_imp1: "(((Q --> R) --> Q) --> Q)
                --> (((P --> Q) --> R) --> P --> Q) --> P --> Q"
  by (tactic "IntPr.fast_tac @{context} 1")

lemma peirce_imp2: "(((P --> R) --> P) --> P) --> ((P --> Q --> R) --> P) --> P"
  by (tactic "IntPr.fast_tac @{context} 1")

lemma mints: "((((P --> Q) --> P) --> P) --> Q) --> Q"
  by (tactic "IntPr.fast_tac @{context} 1")

lemma mints_solovev: "(P --> (Q --> R) --> Q) --> ((P --> Q) --> R) --> R"
  by (tactic "IntPr.fast_tac @{context} 1")

lemma tatsuta: "(((P7 --> P1) --> P10) --> P4 --> P5)
  --> (((P8 --> P2) --> P9) --> P3 --> P10)
  --> (P1 --> P8) --> P6 --> P7
  --> (((P3 --> P2) --> P9) --> P4)
  --> (P1 --> P3) --> (((P6 --> P1) --> P2) --> P9) --> P5"
  by (tactic "IntPr.fast_tac @{context} 1")

lemma tatsuta1: "(((P8 --> P2) --> P9) --> P3 --> P10)
  --> (((P3 --> P2) --> P9) --> P4)
  --> (((P6 --> P1) --> P2) --> P9)
  --> (((P7 --> P1) --> P10) --> P4 --> P5)
  --> (P1 --> P3) --> (P1 --> P8) --> P6 --> P7 --> P5"
  by (tactic "IntPr.fast_tac @{context} 1")

end


(*
    Authors:    René Thiemann
    License:    BSD
*)
section \<open>Optimized Code for Integer-Rational Operations\<close>

theory Int_Rat_Operations
imports
  Sqrt_Babylonian.Sqrt_Babylonian_Auxiliary
  Norms
begin

definition int_times_rat :: "int \<Rightarrow> rat \<Rightarrow> rat" where "int_times_rat i x = of_int i * x"

declare int_times_rat_def[simp]

lemma int_times_rat_code[code abstract]: "quotient_of (int_times_rat i x) =
  (case quotient_of x of (n,d) \<Rightarrow> Rat.normalize (i * n, d))"
  unfolding int_times_rat_def rat_times_code by auto

definition square_rat :: "rat \<Rightarrow> rat" where [simp]: "square_rat x = x * x"

lemma quotient_of_square: assumes "quotient_of x = (a,b)"
  shows "quotient_of (x * x) = (a * a, b * b)"
proof -
  have b0: "b > 0" "b \<noteq> 0" using quotient_of_denom_pos[OF assms] by auto
  hence b: "(b * b > 0) = True" by auto
  show ?thesis
    unfolding rat_times_code assms Let_def split Rat.normalize_def fst_conv snd_conv b if_True
    using quotient_of_coprime[OF assms] b0 by simp
qed

lemma square_rat_code[code abstract]: "quotient_of (square_rat x) = (case quotient_of x of (n,d)
  \<Rightarrow> (n * n, d * d))" using quotient_of_square[of x] unfolding square_rat_def
  by (cases "quotient_of x", auto)

definition scalar_prod_int_rat :: "int vec \<Rightarrow> rat vec \<Rightarrow> rat" (infix "\<bullet>i" 70) where
  "x \<bullet>i y = (y \<bullet> map_vec rat_of_int x)"

lemma scalar_prod_int_rat_code[code]: "v \<bullet>i w = (\<Sum>i = 0..<dim_vec v. int_times_rat (v $ i) (w $ i))"
  unfolding scalar_prod_int_rat_def Let_def scalar_prod_def int_times_rat_def
  by (rule sum.cong, auto)

lemma scalar_prod_int_rat[simp]: "dim_vec x = dim_vec y \<Longrightarrow> x \<bullet>i y = map_vec of_int x \<bullet> y"
  unfolding scalar_prod_int_rat_def by (intro comm_scalar_prod[of _ "dim_vec x"], auto intro: carrier_vecI)

definition sq_norm_vec_rat :: "rat vec \<Rightarrow> rat" where [simp]: "sq_norm_vec_rat x = sq_norm_vec x"

lemma sq_norm_vec_rat_code[code]: "sq_norm_vec_rat x = (\<Sum>x\<leftarrow>list_of_vec x. square_rat x)"
  unfolding sq_norm_vec_rat_def sq_norm_vec_def square_rat_def by auto

end


(*  Title:      HOL/Old_Number_Theory/WilsonBij.thy
    Author:     Thomas M. Rasmussen
    Copyright   2000  University of Cambridge
*)

section {* Wilson's Theorem using a more abstract approach *}

theory WilsonBij
imports BijectionRel IntFact
begin

text {*
  Wilson's Theorem using a more ``abstract'' approach based on
  bijections between sets.  Does not use Fermat's Little Theorem
  (unlike Russinoff).
*}

subsection {* Definitions and lemmas *}

definition reciR :: "int => int => int => bool"
  where "reciR p = (\<lambda>a b. zcong (a * b) 1 p \<and> 1 < a \<and> a < p - 1 \<and> 1 < b \<and> b < p - 1)"

definition inv :: "int => int => int" where
  "inv p a =
    (if zprime p \<and> 0 < a \<and> a < p then
      (SOME x. 0 \<le> x \<and> x < p \<and> zcong (a * x) 1 p)
     else 0)"

text {* \medskip Inverse *}

lemma inv_correct:
  "zprime p ==> 0 < a ==> a < p
    ==> 0 \<le> inv p a \<and> inv p a < p \<and> [a * inv p a = 1] (mod p)"
  apply (unfold inv_def)
  apply (simp (no_asm_simp))
  apply (rule zcong_lineq_unique [THEN ex1_implies_ex, THEN someI_ex])
   apply (erule_tac [2] zless_zprime_imp_zrelprime)
    apply (unfold zprime_def)
    apply auto
  done

lemmas inv_ge = inv_correct [THEN conjunct1]
lemmas inv_less = inv_correct [THEN conjunct2, THEN conjunct1]
lemmas inv_is_inv = inv_correct [THEN conjunct2, THEN conjunct2]

lemma inv_not_0:
  "zprime p ==> 1 < a ==> a < p - 1 ==> inv p a \<noteq> 0"
  -- {* same as @{text WilsonRuss} *}
  apply safe
  apply (cut_tac a = a and p = p in inv_is_inv)
     apply (unfold zcong_def)
     apply auto
  done

lemma inv_not_1:
  "zprime p ==> 1 < a ==> a < p - 1 ==> inv p a \<noteq> 1"
  -- {* same as @{text WilsonRuss} *}
  apply safe
  apply (cut_tac a = a and p = p in inv_is_inv)
     prefer 4
     apply simp
     apply (subgoal_tac "a = 1")
      apply (rule_tac [2] zcong_zless_imp_eq)
          apply auto
  done

lemma aux: "[a * (p - 1) = 1] (mod p) = [a = p - 1] (mod p)"
  -- {* same as @{text WilsonRuss} *}
  apply (unfold zcong_def)
  apply (simp add: diff_diff_eq diff_diff_eq2 right_diff_distrib)
  apply (rule_tac s = "p dvd -((a + 1) + (p * -a))" in trans)
   apply (simp add: algebra_simps)
  apply (subst dvd_minus_iff)
  apply (subst zdvd_reduce)
  apply (rule_tac s = "p dvd (a + 1) + (p * -1)" in trans)
   apply (subst zdvd_reduce)
   apply auto
  done

lemma inv_not_p_minus_1:
  "zprime p ==> 1 < a ==> a < p - 1 ==> inv p a \<noteq> p - 1"
  -- {* same as @{text WilsonRuss} *}
  apply safe
  apply (cut_tac a = a and p = p in inv_is_inv)
     apply auto
  apply (simp add: aux)
  apply (subgoal_tac "a = p - 1")
   apply (rule_tac [2] zcong_zless_imp_eq)
       apply auto
  done

text {*
  Below is slightly different as we don't expand @{term [source] inv}
  but use ``@{text correct}'' theorems.
*}

lemma inv_g_1: "zprime p ==> 1 < a ==> a < p - 1 ==> 1 < inv p a"
  apply (subgoal_tac "inv p a \<noteq> 1")
   apply (subgoal_tac "inv p a \<noteq> 0")
    apply (subst order_less_le)
    apply (subst zle_add1_eq_le [symmetric])
    apply (subst order_less_le)
    apply (rule_tac [2] inv_not_0)
      apply (rule_tac [5] inv_not_1)
        apply auto
  apply (rule inv_ge)
    apply auto
  done

lemma inv_less_p_minus_1:
  "zprime p ==> 1 < a ==> a < p - 1 ==> inv p a < p - 1"
  -- {* ditto *}
  apply (subst order_less_le)
  apply (simp add: inv_not_p_minus_1 inv_less)
  done

text {* \medskip Bijection *}

lemma aux1: "1 < x ==> 0 \<le> (x::int)"
  apply auto
  done

lemma aux2: "1 < x ==> 0 < (x::int)"
  apply auto
  done

lemma aux3: "x \<le> p - 2 ==> x < (p::int)"
  apply auto
  done

lemma aux4: "x \<le> p - 2 ==> x < (p::int) - 1"
  apply auto
  done

lemma inv_inj: "zprime p ==> inj_on (inv p) (d22set (p - 2))"
  apply (unfold inj_on_def)
  apply auto
  apply (rule zcong_zless_imp_eq)
      apply (tactic {* stac (@{thm zcong_cancel} RS sym) 5 *})
        apply (rule_tac [7] zcong_trans)
         apply (tactic {* stac @{thm zcong_sym} 8 *})
         apply (erule_tac [7] inv_is_inv)
          apply (tactic "asm_simp_tac @{context} 9")
          apply (erule_tac [9] inv_is_inv)
           apply (rule_tac [6] zless_zprime_imp_zrelprime)
             apply (rule_tac [8] inv_less)
               apply (rule_tac [7] inv_g_1 [THEN aux2])
                 apply (unfold zprime_def)
                 apply (auto intro: d22set_g_1 d22set_le
                   aux1 aux2 aux3 aux4)
  done

lemma inv_d22set_d22set:
    "zprime p ==> inv p ` d22set (p - 2) = d22set (p - 2)"
  apply (rule endo_inj_surj)
    apply (rule d22set_fin)
   apply (erule_tac [2] inv_inj)
  apply auto
  apply (rule d22set_mem)
   apply (erule inv_g_1)
    apply (subgoal_tac [3] "inv p xa < p - 1")
     apply (erule_tac [4] inv_less_p_minus_1)
      apply (auto intro: d22set_g_1 d22set_le aux4)
  done

lemma d22set_d22set_bij:
    "zprime p ==> (d22set (p - 2), d22set (p - 2)) \<in> bijR (reciR p)"
  apply (unfold reciR_def)
  apply (rule_tac s = "(d22set (p - 2), inv p ` d22set (p - 2))" in subst)
   apply (simp add: inv_d22set_d22set)
  apply (rule inj_func_bijR)
    apply (rule_tac [3] d22set_fin)
   apply (erule_tac [2] inv_inj)
  apply auto
      apply (erule inv_is_inv)
       apply (erule_tac [5] inv_g_1)
        apply (erule_tac [7] inv_less_p_minus_1)
         apply (auto intro: d22set_g_1 d22set_le aux2 aux3 aux4)
  done

lemma reciP_bijP: "zprime p ==> bijP (reciR p) (d22set (p - 2))"
  apply (unfold reciR_def bijP_def)
  apply auto
  apply (rule d22set_mem)
   apply auto
  done

lemma reciP_uniq: "zprime p ==> uniqP (reciR p)"
  apply (unfold reciR_def uniqP_def)
  apply auto
   apply (rule zcong_zless_imp_eq)
       apply (tactic {* stac (@{thm zcong_cancel2} RS sym) 5 *})
         apply (rule_tac [7] zcong_trans)
          apply (tactic {* stac @{thm zcong_sym} 8 *})
          apply (rule_tac [6] zless_zprime_imp_zrelprime)
            apply auto
  apply (rule zcong_zless_imp_eq)
      apply (tactic {* stac (@{thm zcong_cancel} RS sym) 5 *})
        apply (rule_tac [7] zcong_trans)
         apply (tactic {* stac @{thm zcong_sym} 8 *})
         apply (rule_tac [6] zless_zprime_imp_zrelprime)
           apply auto
  done

lemma reciP_sym: "zprime p ==> symP (reciR p)"
  apply (unfold reciR_def symP_def)
  apply (simp add: mult.commute)
  apply auto
  done

lemma bijER_d22set: "zprime p ==> d22set (p - 2) \<in> bijER (reciR p)"
  apply (rule bijR_bijER)
     apply (erule d22set_d22set_bij)
    apply (erule reciP_bijP)
   apply (erule reciP_uniq)
  apply (erule reciP_sym)
  done

subsection {* Wilson *}

lemma bijER_zcong_prod_1:
    "zprime p ==> A \<in> bijER (reciR p) ==> [\<Prod>A = 1] (mod p)"
  apply (unfold reciR_def)
  apply (erule bijER.induct)
    apply (subgoal_tac [2] "a = 1 \<or> a = p - 1")
     apply (rule_tac [3] zcong_square_zless)
        apply auto
  apply (subst setprod.insert)
    prefer 3
    apply (subst setprod.insert)
      apply (auto simp add: fin_bijER)
  apply (subgoal_tac "zcong ((a * b) * \<Prod>A) (1 * 1) p")
   apply (simp add: mult.assoc)
  apply (rule zcong_zmult)
   apply auto
  done

theorem Wilson_Bij: "zprime p ==> [zfact (p - 1) = -1] (mod p)"
  apply (subgoal_tac "zcong ((p - 1) * zfact (p - 2)) (-1 * 1) p")
   apply (rule_tac [2] zcong_zmult)
    apply (simp add: zprime_def)
    apply (subst zfact.simps)
    apply (rule_tac t = "p - 1 - 1" and s = "p - 2" in subst)
     apply auto
   apply (simp add: zcong_def)
  apply (subst d22set_prod_zfact [symmetric])
  apply (rule bijER_zcong_prod_1)
   apply (rule_tac [2] bijER_d22set)
   apply auto
  done

end


(*
Author:  Bertram Felgenhauer <bertram.felgenhauer@uibk.ac.at> (2015)
Author:  Christian Sternagel <c.sternagel@gmail.com> (2013-2016)
Author:  Martin Avanzini <martin.avanzini@uibk.ac.at> (2014)
Author:  René Thiemann <rene.thiemann@uibk.ac.at> (2013-2015)
Author:  Julian Nagele <julian.nagele@uibk.ac.at> (2016)
License: LGPL (see file COPYING.LESSER)
*)

section \<open>Preliminaries\<close>
subsection \<open>Multihole Contexts\<close>

theory Multihole_Context
imports
  Utils
begin

unbundle lattice_syntax

subsubsection \<open>Partitioning lists into chunks of given length\<close>

lemma concat_nth:
  assumes "m < length xs" and "n < length (xs ! m)"
    and "i = sum_list (map length (take m xs)) + n"
  shows "concat xs ! i = xs ! m ! n"
using assms
proof (induct xs arbitrary: m n i)
  case (Cons x xs)
  show ?case
  proof (cases m)
    case 0
    then show ?thesis using Cons by (simp add: nth_append)
  next
    case (Suc k)
    with Cons(1) [of k n "i - length x"] and Cons(2-)
      show ?thesis by (simp_all add: nth_append)
  qed
qed simp

lemma sum_list_take_eq:
  fixes xs :: "nat list"
  shows "k < i \<Longrightarrow> i < length xs \<Longrightarrow> sum_list (take i xs) =
    sum_list (take k xs) + xs ! k + sum_list (take (i - Suc k) (drop (Suc k) xs))"
  by (subst id_take_nth_drop [of k]) (auto simp: min_def drop_take)

fun partition_by where
  "partition_by xs [] = []" |
  "partition_by xs (y#ys) = take y xs # partition_by (drop y xs) ys"

lemma partition_by_map0_append [simp]:
  "partition_by xs (map (\<lambda>x. 0) ys @ zs) = replicate (length ys) [] @ partition_by xs zs"
by (induct ys) simp_all

lemma concat_partition_by [simp]:
  "sum_list ys = length xs \<Longrightarrow> concat (partition_by xs ys) = xs"
by (induct ys arbitrary: xs) simp_all

definition partition_by_idx where
  "partition_by_idx l ys i j = partition_by [0..<l] ys ! i ! j"

lemma partition_by_nth_nth_old:
  assumes "i < length (partition_by xs ys)"
    and "j < length (partition_by xs ys ! i)"
    and "sum_list ys = length xs"
  shows "partition_by xs ys ! i ! j = xs ! (sum_list (map length (take i (partition_by xs ys))) + j)"
  using concat_nth [OF assms(1, 2) refl]
  unfolding concat_partition_by [OF assms(3)] by simp

lemma map_map_partition_by:
  "map (map f) (partition_by xs ys) = partition_by (map f xs) ys"
by (induct ys arbitrary: xs) (auto simp: take_map drop_map)

lemma length_partition_by [simp]:
  "length (partition_by xs ys) = length ys"
  by (induct ys arbitrary: xs) simp_all

lemma partition_by_Nil [simp]:
  "partition_by [] ys = replicate (length ys) []"
  by (induct ys) simp_all

lemma partition_by_concat_id [simp]:
  assumes "length xss = length ys"
    and "\<And>i. i < length ys \<Longrightarrow> length (xss ! i) = ys ! i"
  shows "partition_by (concat xss) ys = xss"
  using assms by (induct ys arbitrary: xss) (simp, case_tac xss, simp, fastforce)

lemma partition_by_nth:
  "i < length ys \<Longrightarrow> partition_by xs ys ! i = take (ys ! i) (drop (sum_list (take i ys)) xs)"
  by (induct ys arbitrary: xs i) (simp, case_tac i, simp_all add: ac_simps)

lemma partition_by_nth_less:
  assumes "k < i" and "i < length zs"
    and "length xs = sum_list (take i zs) + j"
  shows "partition_by (xs @ y # ys) zs ! k = take (zs ! k) (drop (sum_list (take k zs)) xs)"
proof -
  have "partition_by (xs @ y # ys) zs ! k =
    take (zs ! k) (drop (sum_list (take k zs)) (xs @ y # ys))"
    using assms by (auto simp: partition_by_nth)
  moreover have "zs ! k + sum_list (take k zs) \<le> length xs"
    using assms by (simp add: sum_list_take_eq)
  ultimately show ?thesis by simp
qed

lemma partition_by_nth_greater:
  assumes "i < k" and "k < length zs" and "j < zs ! i"
    and "length xs = sum_list (take i zs) + j"
  shows "partition_by (xs @ y # ys) zs ! k =
    take (zs ! k) (drop (sum_list (take k zs) - 1) (xs @ ys))"
proof -
  have "partition_by (xs @ y # ys) zs ! k =
    take (zs ! k) (drop (sum_list (take k zs)) (xs @ y # ys))"
    using assms by (auto simp: partition_by_nth)
  moreover have "sum_list (take k zs) > length xs"
    using assms by (auto simp: sum_list_take_eq)
  ultimately show ?thesis by (auto) (metis Suc_diff_Suc drop_Suc_Cons)
qed

lemma length_partition_by_nth:
  "sum_list ys = length xs \<Longrightarrow> i < length ys \<Longrightarrow> length (partition_by xs ys ! i) = ys ! i"
by (induct ys arbitrary: xs i; case_tac i) auto

lemma partition_by_nth_nth_elem:
  assumes "sum_list ys = length xs" "i < length ys" "j < ys ! i"
  shows "partition_by xs ys ! i ! j \<in> set xs"
proof -
  from assms have "j < length (partition_by xs ys ! i)" by (simp only: length_partition_by_nth)
  then have "partition_by xs ys ! i ! j \<in> set (partition_by xs ys ! i)" by auto
  with assms(2) have "partition_by xs ys ! i ! j \<in> set (concat (partition_by xs ys))" by auto
  then show ?thesis using assms by simp
qed

lemma partition_by_nth_nth:
  assumes "sum_list ys = length xs" "i < length ys" "j < ys ! i"
  shows "partition_by xs ys ! i ! j = xs ! partition_by_idx (length xs) ys i j"
        "partition_by_idx (length xs) ys i j < length xs"
unfolding partition_by_idx_def
proof -
  let ?n = "partition_by [0..<length xs] ys ! i ! j"
  show "?n < length xs"
    using partition_by_nth_nth_elem[OF _ assms(2,3), of "[0..<length xs]"] assms(1) by simp
  have li: "i < length (partition_by [0..<length xs] ys)" using assms(2) by simp
  have lj: "j < length (partition_by [0..<length xs] ys ! i)"
    using assms by (simp add: length_partition_by_nth)
  have "partition_by (map ((!) xs) [0..<length xs]) ys ! i ! j = xs ! ?n"
    by (simp only: map_map_partition_by[symmetric] nth_map[OF li] nth_map[OF lj])
  then show "partition_by xs ys ! i ! j = xs ! ?n" by (simp add: map_nth)
qed

lemma map_length_partition_by [simp]:
  "sum_list ys = length xs \<Longrightarrow> map length (partition_by xs ys) = ys"
  by (intro nth_equalityI, auto simp: length_partition_by_nth)

lemma map_partition_by_nth [simp]:
  "i < length ys \<Longrightarrow> map f (partition_by xs ys ! i) = partition_by (map f xs) ys ! i"
  by (induct ys arbitrary: i xs) (simp, case_tac i, simp_all add: take_map drop_map)

lemma sum_list_partition_by [simp]:
  "sum_list ys = length xs \<Longrightarrow>
    sum_list (map (\<lambda>x. sum_list (map f x)) (partition_by xs ys)) = sum_list (map f xs)"
  by (induct ys arbitrary: xs) (simp_all, metis append_take_drop_id sum_list_append map_append)

lemma partition_by_map_conv:
  "partition_by xs ys = map (\<lambda>i. take (ys ! i) (drop (sum_list (take i ys)) xs)) [0 ..< length ys]"
  by (rule nth_equalityI) (simp_all add: partition_by_nth)

lemma UN_set_partition_by_map:
  "sum_list ys = length xs \<Longrightarrow> (\<Union>x\<in>set (partition_by (map f xs) ys). \<Union> (set x)) = \<Union>(set (map f xs))"
  by (induct ys arbitrary: xs)
     (simp_all add: drop_map take_map, metis UN_Un append_take_drop_id set_append)

lemma UN_set_partition_by:
  "sum_list ys = length xs \<Longrightarrow> (\<Union>zs \<in> set (partition_by xs ys). \<Union>x \<in> set zs. f x) = (\<Union>x \<in> set xs. f x)"
  by (induct ys arbitrary: xs) (simp_all, metis UN_Un append_take_drop_id set_append)

lemma Ball_atLeast0LessThan_partition_by_conv:
  "(\<forall>i\<in>{0..<length ys}. \<forall>x\<in>set (partition_by xs ys ! i). P x) =
    (\<forall>x \<in> \<Union>(set (map set (partition_by xs ys))). P x)"
  by auto (metis atLeast0LessThan in_set_conv_nth length_partition_by lessThan_iff)

lemma Ball_set_partition_by:
  "sum_list ys = length xs \<Longrightarrow>
  (\<forall>x \<in> set (partition_by xs ys). \<forall>y \<in> set x. P y) = (\<forall>x \<in> set xs. P x)"
proof (induct ys arbitrary: xs)
  case (Cons y ys)
  then show ?case
    apply (subst (2) append_take_drop_id [of y xs, symmetric])
    apply (simp only: set_append)
    apply auto
  done
qed simp

lemma partition_by_append2:
  "partition_by xs (ys @ zs) = partition_by (take (sum_list ys) xs) ys @ partition_by (drop (sum_list ys) xs) zs"
by (induct ys arbitrary: xs) (auto simp: drop_take ac_simps split: split_min)

lemma partition_by_concat2:
  "partition_by xs (concat ys) =
   concat (map (\<lambda>i . partition_by (partition_by xs (map sum_list ys) ! i) (ys ! i)) [0..<length ys])"
proof -
  have *: "map (\<lambda>i . partition_by (partition_by xs (map sum_list ys) ! i) (ys ! i)) [0..<length ys] =
    map (\<lambda>(x,y). partition_by x y) (zip (partition_by xs (map sum_list ys)) ys)"
    using zip_nth_conv[of "partition_by xs (map sum_list ys)" ys] by auto
  show ?thesis unfolding * by (induct ys arbitrary: xs) (auto simp: partition_by_append2)
qed

lemma partition_by_partition_by:
  "length xs = sum_list (map sum_list ys) \<Longrightarrow>
   partition_by (partition_by xs (concat ys)) (map length ys) =
   map (\<lambda>i. partition_by (partition_by xs (map sum_list ys) ! i) (ys ! i)) [0..<length ys]"
by (auto simp: partition_by_concat2 intro: partition_by_concat_id)

subsubsection \<open>Multihole contexts definition and functionalities\<close>
datatype ('f, vars_mctxt : 'v) mctxt = MVar 'v | MHole | MFun 'f "('f, 'v) mctxt list"

subsubsection \<open>Conversions from and to multihole contexts\<close>

primrec mctxt_of_term :: "('f, 'v) term \<Rightarrow> ('f, 'v) mctxt" where
  "mctxt_of_term (Var x) = MVar x" |
  "mctxt_of_term (Fun f ts) = MFun f (map mctxt_of_term ts)"

primrec term_of_mctxt :: "('f, 'v) mctxt \<Rightarrow> ('f, 'v) term" where
  "term_of_mctxt (MVar x) = Var x" |
  "term_of_mctxt (MFun f Cs) = Fun f (map term_of_mctxt Cs)"

fun num_holes :: "('f, 'v) mctxt \<Rightarrow> nat" where
  "num_holes (MVar _) = 0" |
  "num_holes MHole = 1" |
  "num_holes (MFun _ ctxts) = sum_list (map num_holes ctxts)"

fun ground_mctxt :: "('f, 'v) mctxt \<Rightarrow> bool" where
  "ground_mctxt (MVar _) = False" |
  "ground_mctxt MHole = True" |
  "ground_mctxt (MFun f Cs) = Ball (set Cs) ground_mctxt"

fun map_mctxt :: "('f \<Rightarrow> 'g) \<Rightarrow> ('f, 'v) mctxt \<Rightarrow> ('g, 'v) mctxt"
where
  "map_mctxt _ (MVar x) = (MVar x)" |
  "map_mctxt _ (MHole) = MHole" |
  "map_mctxt fg (MFun f Cs) = MFun (fg f) (map (map_mctxt fg) Cs)"

abbreviation "partition_holes xs Cs \<equiv> partition_by xs (map num_holes Cs)"
abbreviation "partition_holes_idx l Cs \<equiv> partition_by_idx l (map num_holes Cs)"

fun fill_holes :: "('f, 'v) mctxt \<Rightarrow> ('f, 'v) term list \<Rightarrow> ('f, 'v) term" where
  "fill_holes (MVar x) _ = Var x" |
  "fill_holes MHole [t] = t" |
  "fill_holes (MFun f cs) ts = Fun f (map (\<lambda> i. fill_holes (cs ! i)
    (partition_holes ts cs ! i)) [0 ..< length cs])"

fun fill_holes_mctxt :: "('f, 'v) mctxt \<Rightarrow> ('f, 'v) mctxt list \<Rightarrow> ('f, 'v) mctxt" where
  "fill_holes_mctxt (MVar x) _ = MVar x" |
  "fill_holes_mctxt MHole [] = MHole" |
  "fill_holes_mctxt MHole [t] = t" |
  "fill_holes_mctxt (MFun f cs) ts = (MFun f (map (\<lambda> i. fill_holes_mctxt (cs ! i)
    (partition_holes ts cs ! i)) [0 ..< length cs]))"

fun unfill_holes :: "('f, 'v) mctxt \<Rightarrow> ('f, 'v) term \<Rightarrow> ('f, 'v) term list" where
  "unfill_holes MHole t = [t]"
| "unfill_holes (MVar w) (Var v) = (if v = w then [] else undefined)"
| "unfill_holes (MFun g Cs) (Fun f ts) = (if f = g \<and> length ts = length Cs then
    concat (map (\<lambda>i. unfill_holes (Cs ! i) (ts ! i)) [0..<length ts]) else undefined)"

fun funas_mctxt where
  "funas_mctxt (MFun f Cs) = {(f, length Cs)} \<union> \<Union>(funas_mctxt ` set Cs)" |
  "funas_mctxt _ = {}"

fun split_vars :: "('f, 'v) term \<Rightarrow> (('f, 'v) mctxt \<times> 'v list)" where
  "split_vars (Var x) = (MHole, [x])" |
  "split_vars (Fun f ts) = (MFun f (map (fst \<circ> split_vars) ts), concat (map (snd \<circ> split_vars) ts))"

fun hole_poss_list :: "('f, 'v) mctxt \<Rightarrow> pos list" where
  "hole_poss_list (MVar x) = []" |
  "hole_poss_list MHole = [[]]" |
  "hole_poss_list (MFun f cs) = concat (poss_args hole_poss_list cs)"

fun map_vars_mctxt :: "('v \<Rightarrow> 'w) \<Rightarrow> ('f, 'v) mctxt \<Rightarrow> ('f, 'w) mctxt"
where
  "map_vars_mctxt vw MHole = MHole" |
  "map_vars_mctxt vw (MVar v) = (MVar (vw v))" |
  "map_vars_mctxt vw (MFun f Cs) = MFun f (map (map_vars_mctxt vw) Cs)"

inductive eq_fill :: "('f, 'v) term \<Rightarrow> ('f, 'v) mctxt \<times> ('f, 'v) term list \<Rightarrow> bool" ("(_/ =\<^sub>f _)" [51, 51] 50)
where
  eqfI [intro]: "t = fill_holes D ss \<Longrightarrow> num_holes D = length ss \<Longrightarrow> t =\<^sub>f (D, ss)"

subsubsection \<open>Semilattice Structures\<close>

instantiation mctxt :: (type, type) inf

begin

fun inf_mctxt :: "('a, 'b) mctxt \<Rightarrow> ('a, 'b) mctxt \<Rightarrow> ('a, 'b) mctxt"
where
  "MHole \<sqinter> D = MHole" |
  "C \<sqinter> MHole = MHole" |
  "MVar x \<sqinter> MVar y = (if x = y then MVar x else MHole)" |
  "MFun f Cs \<sqinter> MFun g Ds =
    (if f = g \<and> length Cs = length Ds then MFun f (map (case_prod (\<sqinter>)) (zip Cs Ds))
    else MHole)" |
  "C \<sqinter> D = MHole"

instance ..

end

lemma inf_mctxt_idem [simp]:
  fixes C :: "('f, 'v) mctxt"
  shows "C \<sqinter> C = C"
  by (induct C) (auto simp: zip_same_conv_map intro: map_idI)

lemma inf_mctxt_MHole2 [simp]:
  "C \<sqinter> MHole = MHole"
  by (induct C) simp_all

lemma inf_mctxt_comm [ac_simps]:
  "(C :: ('f, 'v) mctxt) \<sqinter> D = D \<sqinter> C"
  by (induct C D rule: inf_mctxt.induct) (fastforce simp: in_set_conv_nth intro!: nth_equalityI)+

lemma inf_mctxt_assoc [ac_simps]:
  fixes C :: "('f, 'v) mctxt"
  shows "C \<sqinter> D \<sqinter> E = C \<sqinter> (D \<sqinter> E)"
  apply (induct C D arbitrary: E rule: inf_mctxt.induct)
  apply auto
  apply (case_tac E, auto)+
  apply (fastforce simp: in_set_conv_nth intro!: nth_equalityI)
  apply (case_tac E, auto)+
done

instantiation mctxt :: (type, type) order
begin

definition "(C :: ('a, 'b) mctxt) \<le> D \<longleftrightarrow> C \<sqinter> D = C"
definition "(C :: ('a, 'b) mctxt) < D \<longleftrightarrow> C \<le> D \<and> \<not> D \<le> C"

instance
  by (standard, simp_all add: less_eq_mctxt_def less_mctxt_def ac_simps, metis inf_mctxt_assoc)

end

inductive less_eq_mctxt' :: "('f, 'v) mctxt \<Rightarrow> ('f,'v) mctxt \<Rightarrow> bool" where
  "less_eq_mctxt' MHole u"
| "less_eq_mctxt' (MVar v) (MVar v)"
| "length cs = length ds \<Longrightarrow> (\<And>i. i < length cs \<Longrightarrow> less_eq_mctxt' (cs ! i) (ds ! i)) \<Longrightarrow> less_eq_mctxt' (MFun f cs) (MFun f ds)"

subsubsection \<open>Lemmata\<close>

lemma partition_holes_fill_holes_conv:
  "fill_holes (MFun f cs) ts =
    Fun f [fill_holes (cs ! i) (partition_holes ts cs ! i). i \<leftarrow> [0 ..< length cs]]"
  by (simp add: partition_by_nth take_map)

lemma partition_holes_fill_holes_mctxt_conv:
  "fill_holes_mctxt (MFun f Cs) ts =
    MFun f [fill_holes_mctxt (Cs ! i) (partition_holes ts Cs ! i). i \<leftarrow> [0 ..< length Cs]]"
  by (simp add: partition_by_nth take_map)

text \<open>The following induction scheme provides the @{term MFun} case with the list argument split
  according to the argument contexts. This feature is quite delicate: its benefit can be
  destroyed by premature simplification using the @{thm concat_partition_by} simplification rule.\<close>

lemma fill_holes_induct2[consumes 2, case_names MHole MVar MFun]:
  fixes P :: "('f,'v) mctxt \<Rightarrow> 'a list \<Rightarrow> 'b list \<Rightarrow> bool"
  assumes len1: "num_holes C = length xs" and len2: "num_holes C = length ys"
  and Hole: "\<And>x y. P MHole [x] [y]"
  and Var: "\<And>v. P (MVar v) [] []"
  and Fun: "\<And>f Cs xs ys.  sum_list (map num_holes Cs) = length xs \<Longrightarrow>
    sum_list (map num_holes Cs) = length ys \<Longrightarrow>
    (\<And>i. i < length Cs \<Longrightarrow> P (Cs ! i) (partition_holes xs Cs ! i) (partition_holes ys Cs ! i)) \<Longrightarrow>
    P (MFun f Cs) (concat (partition_holes xs Cs)) (concat (partition_holes ys Cs))"
  shows "P C xs ys"
proof (insert len1 len2, induct C arbitrary: xs ys)
  case MHole then show ?case using Hole by (cases xs; cases ys) auto
next
  case (MVar v) then show ?case using Var by auto
next
  case (MFun f Cs) then show ?case using Fun[of Cs xs ys f] by (auto simp: length_partition_by_nth)
qed

lemma fill_holes_induct[consumes 1, case_names MHole MVar MFun]:
  fixes P :: "('f,'v) mctxt \<Rightarrow> 'a list \<Rightarrow> bool"
  assumes len: "num_holes C = length xs"
  and Hole: "\<And>x. P MHole [x]"
  and Var: "\<And>v. P (MVar v) []"
  and Fun: "\<And>f Cs xs. sum_list (map num_holes Cs) = length xs \<Longrightarrow>
    (\<And>i. i < length Cs \<Longrightarrow> P (Cs ! i) (partition_holes xs Cs ! i)) \<Longrightarrow>
    P (MFun f Cs) (concat (partition_holes xs Cs))"
  shows "P C xs"
  using fill_holes_induct2[of C xs xs "\<lambda> C xs _. P C xs"] assms by simp

lemma length_partition_holes_nth [simp]:
  assumes "sum_list (map num_holes cs) = length ts"
    and "i < length cs"
  shows "length (partition_holes ts cs ! i) = num_holes (cs ! i)"
  using assms by (simp add: length_partition_by_nth)

(*some compatibility lemmas (which should be dropped eventually)*)
lemmas
  map_partition_holes_nth [simp] =
    map_partition_by_nth [of _ "map num_holes Cs" for Cs, unfolded length_map] and
  length_partition_holes [simp] =
    length_partition_by [of _ "map num_holes Cs" for Cs, unfolded length_map]

lemma fill_holes_term_of_mctxt:
  "num_holes C = 0 \<Longrightarrow> fill_holes C [] = term_of_mctxt C"
  by (induct C) (auto simp add: map_eq_nth_conv)

lemma fill_holes_MHole:
  "length ts = Suc 0 \<Longrightarrow> ts ! 0 = u \<Longrightarrow> fill_holes MHole ts = u"
  by (cases ts) simp_all

lemma fill_holes_arbitrary:
  assumes lCs: "length Cs = length ts"
    and lss: "length ss = length ts"
    and rec: "\<And> i. i < length ts \<Longrightarrow> num_holes (Cs ! i) = length (ss ! i) \<and> f (Cs ! i) (ss ! i) = ts ! i"
  shows "map (\<lambda>i. f (Cs ! i) (partition_holes (concat ss) Cs ! i)) [0 ..< length Cs] = ts"
proof -
  have "sum_list (map num_holes Cs) = length (concat ss)" using assms
    by (auto simp: length_concat map_nth_eq_conv intro: arg_cong[of _ _ "sum_list"])
  moreover have "partition_holes (concat ss) Cs = ss"
    using assms by (auto intro: partition_by_concat_id)
  ultimately show ?thesis using assms by (auto intro: nth_equalityI)
qed

lemma fill_holes_MFun:
  assumes lCs: "length Cs = length ts"
    and lss: "length ss = length ts"
    and rec: "\<And> i. i < length ts \<Longrightarrow> num_holes (Cs ! i) = length (ss ! i) \<and> fill_holes (Cs ! i) (ss ! i) = ts ! i"
  shows "fill_holes (MFun f Cs) (concat ss) = Fun f ts"
  unfolding fill_holes.simps term.simps
    by (rule conjI[OF refl], rule fill_holes_arbitrary[OF lCs lss rec])

lemma eqfE:
  assumes "t =\<^sub>f (D, ss)" shows "t = fill_holes D ss" "num_holes D = length ss"
  using assms[unfolded eq_fill.simps] by auto

lemma eqf_MFunE:
  assumes "s =\<^sub>f (MFun f Cs,ss)"
  obtains ts sss where "s = Fun f ts" "length ts = length Cs" "length sss = length Cs"
  "\<And> i. i < length Cs \<Longrightarrow> ts ! i =\<^sub>f (Cs ! i, sss ! i)"
  "ss = concat sss"
proof -
  from eqfE[OF assms] have fh: "s = fill_holes (MFun f Cs) ss"
    and nh: "sum_list (map num_holes Cs) = length ss" by auto
  from fh obtain ts where s: "s = Fun f ts" by (cases s, auto)
  from fh[unfolded s]
  have ts: "ts = map (\<lambda>i. fill_holes (Cs ! i) (partition_holes ss Cs ! i)) [0..<length Cs]"
    (is "_ = map (?f Cs ss) _")
    by auto
  let ?sss = "partition_holes ss Cs"
  from nh
  have *: "length ?sss = length Cs" "\<And>i. i < length Cs \<Longrightarrow> ts ! i =\<^sub>f (Cs ! i, ?sss ! i)" "ss = concat ?sss"
    by (auto simp: ts)
  have len: "length ts = length Cs" unfolding ts by auto
  assume ass: "\<And>ts sss. s = Fun f ts \<Longrightarrow>
              length ts = length Cs \<Longrightarrow>
              length sss = length Cs \<Longrightarrow> (\<And>i. i < length Cs \<Longrightarrow> ts ! i =\<^sub>f (Cs ! i, sss ! i)) \<Longrightarrow> ss = concat sss \<Longrightarrow> thesis"
  show thesis
    by (rule ass[OF s len *])
qed

lemma eqf_MFunI:
  assumes "length sss = length Cs"
    and "length ts = length Cs"
    and"\<And> i. i < length Cs \<Longrightarrow> ts ! i =\<^sub>f (Cs ! i, sss ! i)"
  shows "Fun f ts =\<^sub>f (MFun f Cs, concat sss)"
proof
  have "num_holes (MFun f Cs) = sum_list (map num_holes Cs)" by simp
  also have "map num_holes Cs = map length sss"
    by (rule nth_equalityI, insert assms eqfE[OF assms(3)], auto)
  also have "sum_list (\<dots>) = length (concat sss)" unfolding length_concat ..
  finally show "num_holes (MFun f Cs) = length (concat sss)" .
  show "Fun f ts = fill_holes (MFun f Cs) (concat sss)"
    by (rule fill_holes_MFun[symmetric], insert assms(1,2) eqfE[OF assms(3)], auto)
qed

lemma split_vars_ground_vars:
  assumes "ground_mctxt C" and "num_holes C = length xs"
  shows "split_vars (fill_holes C (map Var xs)) = (C, xs)" using assms
proof (induct C arbitrary: xs)
  case (MHole xs)
  then show ?case by (cases xs, auto)
next
  case (MFun f Cs xs)
  have "fill_holes (MFun f Cs) (map Var xs) =\<^sub>f (MFun f Cs, map Var xs)"
    by (rule eqfI, insert MFun(3), auto)
  from eqf_MFunE[OF this]
  obtain ts xss where fh: "fill_holes (MFun f Cs) (map Var xs) = Fun f ts"
    and lent: "length ts = length Cs"
    and lenx: "length xss = length Cs"
    and args: "\<And>i. i < length Cs \<Longrightarrow> ts ! i =\<^sub>f (Cs ! i, xss ! i)"
    and id: "map Var xs = concat xss" by auto
  from arg_cong[OF id, of "map the_Var"] have id2: "xs = concat (map (map the_Var) xss)"
    by (metis map_concat length_map map_nth_eq_conv term.sel(1))
  {
    fix i
    assume i: "i < length Cs"
    then have mem: "Cs ! i \<in> set Cs" by auto
    with MFun(2) have ground: "ground_mctxt (Cs ! i)" by auto
    have "map Var (map the_Var (xss ! i)) = map id (xss ! i)" unfolding map_map o_def map_eq_conv
    proof
      fix x
      assume "x \<in> set (xss ! i)"
      with lenx i have "x \<in> set (concat xss)" by auto
      from this[unfolded id[symmetric]] show "Var (the_Var x) = id x" by auto
    qed
    then have idxss: "map Var (map the_Var (xss ! i)) = xss ! i" by auto
    note rec = eqfE[OF args[OF i]]
    note IH = MFun(1)[OF mem ground, of "map the_Var (xss ! i)", unfolded rec(2) idxss rec(1)[symmetric]]
    from IH have "split_vars (ts ! i) = (Cs ! i, map the_Var (xss ! i))" by auto
    note this idxss
  }
  note IH = this
  have "?case = (map fst (map split_vars ts) = Cs \<and> concat (map snd (map split_vars ts)) = concat (map (map the_Var) xss))"
    unfolding fh unfolding id2 by auto
  also have "\<dots>"
  proof (rule conjI[OF nth_equalityI arg_cong[of _ _ concat, OF nth_equalityI, rule_format]], unfold length_map lent lenx)
    fix i
    assume i: "i < length Cs"
    with arg_cong[OF IH(2)[OF this], of "map the_Var"]
      IH[OF this] show "map snd (map split_vars ts) ! i = map (map the_Var) xss ! i" using lent lenx by auto
  qed (insert IH lent, auto)
  finally show ?case .
qed auto

lemma split_vars_vars_term_list: "snd (split_vars t) = vars_term_list t"
proof (induct t)
  case (Fun f ts)
  then show ?case by (auto simp: vars_term_list.simps o_def, induct ts, auto)
qed (auto simp: vars_term_list.simps)

lemma split_vars_num_holes: "num_holes (fst (split_vars t)) = length (snd (split_vars t))"
proof (induct t)
  case (Fun f ts)
  then show ?case by (induct ts, auto)
qed simp

lemma ground_eq_fill: "t =\<^sub>f (C,ss) \<Longrightarrow> ground t = (ground_mctxt C \<and> (\<forall> s \<in> set ss. ground s))"
proof (induct C arbitrary: t ss)
  case (MVar x)
  from eqfE[OF this] show ?case by simp
next
  case (MHole t ss)
  from eqfE[OF this] show ?case by (cases ss, auto)
next
  case (MFun f Cs s ss)
  from eqf_MFunE[OF MFun(2)] obtain ts sss where s: "s = Fun f ts" and len: "length ts = length Cs" "length sss = length Cs"
    and IH: "\<And> i. i < length Cs \<Longrightarrow> ts ! i =\<^sub>f (Cs ! i, sss ! i)" and ss: "ss = concat sss" by metis
  {
    fix i
    assume i: "i < length Cs"
    then have "Cs ! i \<in> set Cs" by simp
    from MFun(1)[OF this IH[OF i]]
    have "ground (ts ! i) = (ground_mctxt (Cs ! i) \<and> (\<forall>a\<in>set (sss ! i). ground a))" .
  } note IH = this
  note conv = set_conv_nth
  have "?case = ((\<forall>x\<in>set ts. ground x) = ((\<forall>x\<in>set Cs. ground_mctxt x) \<and> (\<forall>a\<in>set sss. \<forall>x\<in>set a. ground x)))"
    unfolding s ss by simp
  also have "..." unfolding conv[of ts] conv[of Cs] conv[of sss] len using IH by auto
  finally show ?case by simp
qed

lemma ground_fill_holes:
  assumes nh: "num_holes C = length ss"
  shows "ground (fill_holes C ss) = (ground_mctxt C \<and> (\<forall> s \<in> set ss. ground s))"
  by (rule ground_eq_fill[OF eqfI[OF refl nh]])

lemma split_vars_ground' [simp]:
  "ground_mctxt (fst (split_vars t))"
  by (induct t) auto

lemma split_vars_funas_mctxt [simp]:
  "funas_mctxt (fst (split_vars t)) = funas_term t"
  by (induct t) auto

lemma less_eq_mctxt_prime: "C \<le> D \<longleftrightarrow> less_eq_mctxt' C D"
proof
  assume "less_eq_mctxt' C D" then show "C \<le> D"
    by (induct C D rule: less_eq_mctxt'.induct) (auto simp: less_eq_mctxt_def intro: nth_equalityI)
next
  assume "C \<le> D" then show "less_eq_mctxt' C D" unfolding less_eq_mctxt_def
  by (induct C D rule: inf_mctxt.induct)
     (auto split: if_splits simp: set_zip intro!: less_eq_mctxt'.intros nth_equalityI elim!: nth_equalityE, metis)
qed

lemmas less_eq_mctxt_induct = less_eq_mctxt'.induct[folded less_eq_mctxt_prime, consumes 1]
lemmas less_eq_mctxt_intros = less_eq_mctxt'.intros[folded less_eq_mctxt_prime]

lemma less_eq_mctxt_MHoleE2:
  assumes "C \<le> MHole"
  obtains (MHole) "C = MHole"
  using assms unfolding less_eq_mctxt_prime by (cases C, auto)

lemma less_eq_mctxt_MVarE2:
  assumes "C \<le> MVar v"
  obtains (MHole) "C = MHole" | (MVar) "C = MVar v"
  using assms unfolding less_eq_mctxt_prime by (cases C) auto

lemma less_eq_mctxt_MFunE2:
  assumes "C \<le> MFun f ds"
  obtains (MHole) "C = MHole"
    | (MFun) cs where "C = MFun f cs" "length cs = length ds" "\<And>i. i < length cs \<Longrightarrow> cs ! i \<le> ds ! i"
  using assms unfolding less_eq_mctxt_prime by (cases C) auto

lemmas less_eq_mctxtE2 = less_eq_mctxt_MHoleE2 less_eq_mctxt_MVarE2 less_eq_mctxt_MFunE2

lemma less_eq_mctxt_MVarE1:
  assumes "MVar v \<le> D"
  obtains (MVar) "D = MVar v"
  using assms by (cases D) (auto elim: less_eq_mctxtE2)

lemma MHole_Bot [simp]: "MHole \<le> D"
  by (simp add: less_eq_mctxt_intros(1))

lemma less_eq_mctxt_MFunE1:
  assumes "MFun f cs \<le> D"
  obtains (MFun) ds where "D = MFun f ds" "length cs = length ds" "\<And>i. i < length cs \<Longrightarrow> cs ! i \<le> ds ! i"
  using assms by (cases D) (auto elim: less_eq_mctxtE2)

lemma length_unfill_holes [simp]:
  assumes "C \<le> mctxt_of_term t"
  shows "length (unfill_holes C t) = num_holes C"
  using assms
proof (induct C t rule: unfill_holes.induct)
  case (3 f Cs g ts) with 3(1)[OF _ nth_mem] 3(2) show ?case
    by (auto simp: less_eq_mctxt_def length_concat
      intro!: cong[of sum_list, OF refl] nth_equalityI elim!: nth_equalityE)
qed (auto simp: less_eq_mctxt_def)

lemma map_vars_mctxt_id [simp]:
  "map_vars_mctxt (\<lambda> x. x) C = C"
  by (induct C, auto intro: nth_equalityI)

lemma split_vars_eqf_subst_map_vars_term:
  "t \<cdot> \<sigma> =\<^sub>f (map_vars_mctxt vw (fst (split_vars t)), map \<sigma> (snd (split_vars t)))"
proof (induct t)
  case (Fun f ts)
  have "?case = (Fun f (map (\<lambda>t. t \<cdot> \<sigma>) ts)
    =\<^sub>f (MFun f (map (map_vars_mctxt vw \<circ> (fst \<circ> split_vars)) ts), concat (map (map \<sigma> \<circ> (snd \<circ> split_vars)) ts)))"
    by (simp add: map_concat)
  also have "..."
  proof (rule eqf_MFunI, simp, simp, unfold length_map)
    fix i
    assume i: "i < length ts"
    then have mem: "ts ! i \<in> set ts" by auto
    show "map (\<lambda>t. t \<cdot> \<sigma>) ts ! i =\<^sub>f (map (map_vars_mctxt vw \<circ> (fst \<circ> split_vars)) ts ! i, map (map \<sigma> \<circ> (snd \<circ> split_vars)) ts ! i)"
      using Fun[OF mem] i by auto
  qed
  finally show ?case by simp
qed auto

lemma split_vars_eqf_subst: "t \<cdot> \<sigma> =\<^sub>f (fst (split_vars t), (map \<sigma> (snd (split_vars t))))"
  using split_vars_eqf_subst_map_vars_term[of t \<sigma> "\<lambda> x. x"] by simp

lemma split_vars_fill_holes:
  assumes "C = fst (split_vars s)" and "ss = map Var (snd (split_vars s))"
  shows "fill_holes C ss = s" using assms
  by (metis eqfE(1) split_vars_eqf_subst subst_apply_term_empty)

lemma fill_unfill_holes:
  assumes "C \<le> mctxt_of_term t"
  shows "fill_holes C (unfill_holes C t) = t"
  using assms
proof (induct C t rule: unfill_holes.induct)
  case (3 f Cs g ts) with 3(1)[OF _ nth_mem] 3(2) show ?case
    by (auto simp: less_eq_mctxt_def intro!: fill_holes_arbitrary elim!: nth_equalityE)
qed (auto simp: less_eq_mctxt_def split: if_splits)

lemma hole_poss_list_length:
  "length (hole_poss_list D) = num_holes D"
  by (induct D) (auto simp: length_concat intro!: nth_sum_listI)

lemma unfill_holles_hole_poss_list_length:
  assumes "C \<le> mctxt_of_term t"
  shows "length (unfill_holes C t) = length (hole_poss_list C)" using assms
proof (induct C arbitrary: t)
  case (MVar x)
  then have [simp]: "t = Var x" by (cases t) (auto dest: less_eq_mctxt_MVarE1)
  show ?case by simp
next
  case (MFun f ts) then show ?case
    by (cases t) (auto simp: length_concat comp_def
      elim!: less_eq_mctxt_MFunE1 less_eq_mctxt_MVarE1 intro!: nth_sum_listI)
qed auto

lemma unfill_holes_to_subst_at_hole_poss:
  assumes "C \<le> mctxt_of_term t"
  shows "unfill_holes C t = map ((|_) t) (hole_poss_list C)" using assms
proof (induct C arbitrary: t)
  case (MVar x)
  then show ?case by (cases t) (auto elim: less_eq_mctxt_MVarE1)
next
  case (MFun f ts)
  from MFun(2) obtain ss where [simp]: "t = Fun f ss" and l: "length ts = length ss"
    by (cases t) (auto elim: less_eq_mctxt_MFunE1)
  let ?ts = "map (\<lambda>i. unfill_holes (ts ! i) (ss ! i)) [0..<length ts]"
  let ?ss = "map (\<lambda> x. map ((|_) (Fun f ss)) (case x of (x, y) \<Rightarrow> map ((#) x) (hole_poss_list y))) (zip [0..<length ts] ts)"
  have eq_l [simp]: "length (concat ?ts) = length (concat ?ss)" using MFun
    by (auto simp: length_concat comp_def elim!: less_eq_mctxt_MFunE1 split!: prod.splits intro!: nth_sum_listI)
  {fix i assume ass: "i < length (concat ?ts)"
    then have lss: "i < length (concat ?ss)" by auto
    obtain m n where [simp]: "concat_index_split (0, i) ?ts = (m, n)" by fastforce
    then have [simp]: "concat_index_split (0, i) ?ss = (m, n)" using concat_index_split_unique[OF ass, of ?ss 0] MFun(2)
      by (auto simp: unfill_holles_hole_poss_list_length[of "ts ! i" "ss ! i" for i]
       simp del: length_unfill_holes elim!: less_eq_mctxt_MFunE1)
    from concat_index_split_less_length_concat(2-)[OF ass ] concat_index_split_less_length_concat(2-)[OF lss]
    have "concat ?ts ! i = concat ?ss! i" using MFun(1)[OF nth_mem, of m "ss ! m"] MFun(2)
      by (auto elim!: less_eq_mctxt_MFunE1)} note nth = this
  show ?case using MFun
    by (auto simp: comp_def map_concat length_concat
        elim!: less_eq_mctxt_MFunE1 split!: prod.splits
        intro!: nth_equalityI nth_sum_listI nth)
qed auto

lemma hole_poss_split_varposs_list_length [simp]:
  "length (hole_poss_list (fst (split_vars t))) = length (varposs_list t)"
  by (induct t)(auto simp: length_concat comp_def intro!: nth_sum_listI)

lemma hole_poss_split_vars_varposs_list:
  "hole_poss_list (fst (split_vars t)) = varposs_list t"
proof (induct t)
  case (Fun f ts)
  let ?ts = "poss_args hole_poss_list (map (fst \<circ> split_vars) ts)"
  let ?ss = "poss_args varposs_list ts"
  have len: "length (concat ?ts) = length (concat ?ss)" "length ?ts = length ?ss"
    "\<forall> i < length ?ts. length (?ts ! i) = length (?ss ! i)" by (auto intro: eq_length_concat_nth)
  {fix i assume ass: "i < length (concat ?ts)"
    then have lss: "i < length (concat ?ss)" using len by auto
    obtain m n where int: "concat_index_split (0, i) ?ts = (m, n)" by fastforce
    then have [simp]: "concat_index_split (0, i) ?ss = (m, n)" using concat_index_split_unique[OF ass len(2-)] by auto
    from concat_index_split_less_length_concat(2-)[OF ass int] concat_index_split_less_length_concat(2-)[OF lss]
    have "concat ?ts ! i = concat ?ss! i" using Fun[OF nth_mem, of m] by auto}
  then show ?case using len by (auto intro: nth_equalityI)
qed auto

lemma funas_term_fill_holes_iff: "num_holes C = length ts \<Longrightarrow>
   g \<in> funas_term (fill_holes C ts) \<longleftrightarrow> g \<in> funas_mctxt C \<or> (\<exists>t \<in> set ts. g \<in> funas_term t)"
proof (induct C ts rule: fill_holes_induct)
  case (MFun f Cs ts)
  have "(\<exists>i < length Cs. g \<in> funas_term (fill_holes (Cs ! i) (partition_holes (concat (partition_holes ts Cs)) Cs ! i)))
    \<longleftrightarrow> (\<exists>C \<in> set Cs. g \<in> funas_mctxt C) \<or> (\<exists>us \<in> set (partition_holes ts Cs). \<exists>t \<in> set us. g \<in> funas_term t)"
    using MFun by (auto simp: ex_set_conv_ex_nth) blast
  then show ?case by auto
qed auto

lemma vars_term_fill_holes [simp]:
  "num_holes C = length ts \<Longrightarrow> ground_mctxt C \<Longrightarrow>
    vars_term (fill_holes C ts) = \<Union>(vars_term ` set ts)"
proof (induct C arbitrary: ts)
  case MHole
  then show ?case by (cases ts) simp_all
next
  case (MFun f Cs)
  then have *: "length (partition_holes ts Cs) = length Cs" by simp
  let ?f = "\<lambda>x. \<Union>y \<in> set x. vars_term y"
  show ?case
    using MFun
    unfolding partition_holes_fill_holes_conv
    by (simp add: UN_upt_len_conv [OF *, of ?f] UN_set_partition_by)
qed simp

lemma funas_mctxt_fill_holes [simp]:
  assumes "num_holes C = length ts"
  shows "funas_term (fill_holes C ts) = funas_mctxt C \<union> \<Union>(set (map funas_term ts))"
  using funas_term_fill_holes_iff[OF assms] by auto

lemma funas_mctxt_fill_holes_mctxt [simp]:
  assumes "num_holes C = length Ds"
  shows "funas_mctxt (fill_holes_mctxt C Ds) = funas_mctxt C \<union> \<Union>(set (map funas_mctxt Ds))"
  (is "?f C Ds = ?g C Ds")
using assms
proof (induct C arbitrary: Ds)
  case MHole
  then show ?case by (cases Ds) simp_all
next
  case (MFun f Cs)
  then have num_holes: "sum_list (map num_holes Cs) = length Ds" by simp
  let ?ys = "partition_holes Ds Cs"
  have "\<And>i. i < length Cs \<Longrightarrow> ?f (Cs ! i) (?ys ! i) = ?g (Cs ! i) (?ys ! i)"
    using MFun by (metis nth_mem num_holes.simps(3) length_partition_holes_nth)
  then have "(\<Union>i \<in> {0 ..< length Cs}. ?f (Cs ! i) (?ys ! i)) =
    (\<Union>i \<in> {0 ..< length Cs}. ?g (Cs ! i) (?ys ! i))" by simp
  then show ?case
    using num_holes
    unfolding partition_holes_fill_holes_mctxt_conv
    by (simp add: UN_Un_distrib UN_upt_len_conv [of _ _ "\<lambda>x. \<Union>(set x)"] UN_set_partition_by_map)
qed simp

end


(* Author: Gerwin Klein, Tobias Nipkow *)

theory Big_Step_7_8 imports Com_7_8 begin

subsection "Big-Step Semantics of Commands"

text {*
The big-step semantics is a straight-forward inductive definition
with concrete syntax. Note that the first paramenter is a tuple,
so the syntax becomes @{text "(c,s) \<Rightarrow> s'"}.
*}

text_raw{*\snip{BigStepdef}{0}{1}{% *}
inductive
  big_step :: "com \<times> state \<Rightarrow> state \<Rightarrow> bool" (infix "\<Rightarrow>" 55)
where
Skip: "(SKIP,s) \<Rightarrow> s" |
Assign: "(x ::= a,s) \<Rightarrow> s(x := aval a s)" |
Seq: "\<lbrakk> (c\<^sub>1,s\<^sub>1) \<Rightarrow> s\<^sub>2;  (c\<^sub>2,s\<^sub>2) \<Rightarrow> s\<^sub>3 \<rbrakk> \<Longrightarrow> (c\<^sub>1;;c\<^sub>2, s\<^sub>1) \<Rightarrow> s\<^sub>3" |
IfTrue: "\<lbrakk> bval b s;  (c\<^sub>1,s) \<Rightarrow> t \<rbrakk> \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<Rightarrow> t" |
IfFalse: "\<lbrakk> \<not>bval b s;  (c\<^sub>2,s) \<Rightarrow> t \<rbrakk> \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<Rightarrow> t" |
WhileFalse: "\<not>bval b s \<Longrightarrow> (WHILE b DO c,s) \<Rightarrow> s" |
WhileTrue:
"\<lbrakk> bval b s\<^sub>1;  (c,s\<^sub>1) \<Rightarrow> s\<^sub>2;  (WHILE b DO c, s\<^sub>2) \<Rightarrow> s\<^sub>3 \<rbrakk>
\<Longrightarrow> (WHILE b DO c, s\<^sub>1) \<Rightarrow> s\<^sub>3" |
RepeatTrue: "\<lbrakk> bval b t;  (c, s) \<Rightarrow> t \<rbrakk> \<Longrightarrow> (REPEAT c UNTIL b, s) \<Rightarrow> t" |
RepeatFalse:
"\<lbrakk> \<not>bval b s\<^sub>2;  (c, s\<^sub>1) \<Rightarrow> s\<^sub>2;  (REPEAT c UNTIL b, s\<^sub>2) \<Rightarrow> s\<^sub>3  \<rbrakk>
\<Longrightarrow> (REPEAT c UNTIL b, s\<^sub>1) \<Rightarrow> s\<^sub>3"

text_raw{*}%endsnip*}

text_raw{*\snip{BigStepEx}{1}{2}{% *}
schematic_lemma ex: "(''x'' ::= N 5;; ''y'' ::= V ''x'', s) \<Rightarrow> ?t"
apply(rule Seq)
apply(rule Assign)
apply simp
apply(rule Assign)
done
text_raw{*}%endsnip*}

thm ex[simplified]

text{* We want to execute the big-step rules: *}

code_pred big_step .

text{* For inductive definitions we need command
       \texttt{values} instead of \texttt{value}. *}

values "{t. (SKIP, \<lambda>_. 0) \<Rightarrow> t}"

text{* We need to translate the result state into a list
to display it. *}

values "{map t [''x''] |t. (SKIP, <''x'' := 42>) \<Rightarrow> t}"

values "{map t [''x''] |t. (''x'' ::= N 2, <''x'' := 42>) \<Rightarrow> t}"

values "{map t [''x'',''y''] |t.
  (WHILE Less (V ''x'') (V ''y'') DO (''x'' ::= Plus (V ''x'') (N 5)),
   <''x'' := 0, ''y'' := 13>) \<Rightarrow> t}"

values "{map t [''x'',''y''] |t.
  (REPEAT (''x'' ::= Plus (V ''x'') (N 5)) UNTIL Less  (V ''y'') (V ''x''),
   <''x'' := 0, ''y'' := 13>) \<Rightarrow> t}"

text{* Proof automation: *}

text {* The introduction rules are good for automatically
construction small program executions. The recursive cases
may require backtracking, so we declare the set as unsafe
intro rules. *}
declare big_step.intros [intro]

text{* The standard induction rule
@{thm [display] big_step.induct [no_vars]} *}

thm big_step.induct

text{*
This induction schema is almost perfect for our purposes, but
our trick for reusing the tuple syntax means that the induction
schema has two parameters instead of the @{text c}, @{text s},
and @{text s'} that we are likely to encounter. Splitting
the tuple parameter fixes this:
*}
lemmas big_step_induct = big_step.induct[split_format(complete)]
thm big_step_induct
text {*
@{thm [display] big_step_induct [no_vars]}
*}

subsection "Rule inversion"

text{* What can we deduce from @{prop "(SKIP,s) \<Rightarrow> t"} ?
That @{prop "s = t"}. This is how we can automatically prove it: *}

inductive_cases SkipE[elim!]: "(SKIP,s) \<Rightarrow> t"
thm SkipE

text{* This is an \emph{elimination rule}. The [elim] attribute tells auto,
blast and friends (but not simp!) to use it automatically; [elim!] means that
it is applied eagerly.

Similarly for the other commands: *}

inductive_cases AssignE[elim!]: "(x ::= a,s) \<Rightarrow> t"
thm AssignE
inductive_cases SeqE[elim!]: "(c1;;c2,s1) \<Rightarrow> s3"
thm SeqE
inductive_cases IfE[elim!]: "(IF b THEN c1 ELSE c2,s) \<Rightarrow> t"
thm IfE

inductive_cases WhileE[elim]: "(WHILE b DO c,s) \<Rightarrow> t"
thm WhileE
text{* Only [elim]: [elim!] would not terminate. *}

inductive_cases RepeatE[elim]: "(REPEAT c UNTIL b,s) \<Rightarrow> t"
thm RepeatE
text{* An automatic example: *}

text{* Rule inversion by hand via the ``cases'' method: *}

lemma assumes "(IF b THEN SKIP ELSE SKIP, s) \<Rightarrow> t"
shows "t = s"
proof-
  from assms show ?thesis
  proof cases  --"inverting assms"
    case IfTrue thm IfTrue
    thus ?thesis by blast
  next
    case IfFalse thus ?thesis by blast
  qed
qed

(* Using rule inversion to prove simplification rules: *)
lemma assign_simp:
  "(x ::= a,s) \<Rightarrow> s' \<longleftrightarrow> (s' = s(x := aval a s))"
  by auto

text {* An example combining rule inversion and derivations *}
lemma Seq_assoc:
  "(c1;; c2;; c3, s) \<Rightarrow> s' \<longleftrightarrow> (c1;; (c2;; c3), s) \<Rightarrow> s'"
proof
  assume "(c1;; c2;; c3, s) \<Rightarrow> s'"
  then obtain s1 s2 where
    c1: "(c1, s) \<Rightarrow> s1" and
    c2: "(c2, s1) \<Rightarrow> s2" and
    c3: "(c3, s2) \<Rightarrow> s'" by auto
  from c2 c3
  have "(c2;; c3, s1) \<Rightarrow> s'" by (rule Seq)
  with c1
  show "(c1;; (c2;; c3), s) \<Rightarrow> s'" by (rule Seq)
next
  -- "The other direction is analogous"
  assume "(c1;; (c2;; c3), s) \<Rightarrow> s'"
  thus "(c1;; c2;; c3, s) \<Rightarrow> s'" by auto
qed

subsection "Command Equivalence"

text {*
  We call two statements @{text c} and @{text c'} equivalent wrt.\ the
  big-step semantics when \emph{@{text c} started in @{text s} terminates
  in @{text s'} iff @{text c'} started in the same @{text s} also terminates
  in the same @{text s'}}. Formally:
*}
text_raw{*\snip{BigStepEquiv}{0}{1}{% *}
abbreviation
  equiv_c :: "com \<Rightarrow> com \<Rightarrow> bool" (infix "\<sim>" 50) where
  "c \<sim> c' \<equiv> (\<forall>s t. (c,s) \<Rightarrow> t  =  (c',s) \<Rightarrow> t)"
text_raw{*}%endsnip*}

text {*
Warning: @{text"\<sim>"} is the symbol written \verb!\ < s i m >! (without spaces).

  As an example, we show that loop unfolding is an equivalence
  transformation on programs:
*}
lemma unfold_while:
  "(WHILE b DO c) \<sim> (IF b THEN c;; WHILE b DO c ELSE SKIP)" (is "?w \<sim> ?iw")
proof -
  -- "to show the equivalence, we look at the derivation tree for"
  -- "each side and from that construct a derivation tree for the other side"
  { fix s t assume "(?w, s) \<Rightarrow> t"
    -- "as a first thing we note that, if @{text b} is @{text False} in state @{text s},"
    -- "then both statements do nothing:"
    { assume "\<not>bval b s"
      hence "t = s" using `(?w,s) \<Rightarrow> t` by blast
      hence "(?iw, s) \<Rightarrow> t" using `\<not>bval b s` by blast
    }
    moreover
    -- "on the other hand, if @{text b} is @{text True} in state @{text s},"
    -- {* then only the @{text WhileTrue} rule can have been used to derive @{text "(?w, s) \<Rightarrow> t"} *}
    { assume "bval b s"
      with `(?w, s) \<Rightarrow> t` obtain s' where
        "(c, s) \<Rightarrow> s'" and "(?w, s') \<Rightarrow> t" by auto
      -- "now we can build a derivation tree for the @{text IF}"
      -- "first, the body of the True-branch:"
      hence "(c;; ?w, s) \<Rightarrow> t" by (rule Seq)
      -- "then the whole @{text IF}"
      with `bval b s` have "(?iw, s) \<Rightarrow> t" by (rule IfTrue)
    }
    ultimately
    -- "both cases together give us what we want:"
    have "(?iw, s) \<Rightarrow> t" by blast
  }
  moreover
  -- "now the other direction:"
  { fix s t assume "(?iw, s) \<Rightarrow> t"
    -- "again, if @{text b} is @{text False} in state @{text s}, then the False-branch"
    -- "of the @{text IF} is executed, and both statements do nothing:"
    { assume "\<not>bval b s"
      hence "s = t" using `(?iw, s) \<Rightarrow> t` by blast
      hence "(?w, s) \<Rightarrow> t" using `\<not>bval b s` by blast
    }
    moreover
    -- "on the other hand, if @{text b} is @{text True} in state @{text s},"
    -- {* then this time only the @{text IfTrue} rule can have be used *}
    { assume "bval b s"
      with `(?iw, s) \<Rightarrow> t` have "(c;; ?w, s) \<Rightarrow> t" by auto
      -- "and for this, only the Seq-rule is applicable:"
      then obtain s' where
        "(c, s) \<Rightarrow> s'" and "(?w, s') \<Rightarrow> t" by auto
      -- "with this information, we can build a derivation tree for the @{text WHILE}"
      with `bval b s`
      have "(?w, s) \<Rightarrow> t" by (rule WhileTrue)
    }
    ultimately
    -- "both cases together again give us what we want:"
    have "(?w, s) \<Rightarrow> t" by blast
  }
  ultimately
  show ?thesis by blast
qed

text {* Luckily, such lengthy proofs are seldom necessary.  Isabelle can
prove many such facts automatically.  *}

lemma while_unfold:
  "(WHILE b DO c) \<sim> (IF b THEN c;; WHILE b DO c ELSE SKIP)"
by blast

lemma triv_if:
  "(IF b THEN c ELSE c) \<sim> c"
by blast

lemma commute_if:
  "(IF b1 THEN (IF b2 THEN c11 ELSE c12) ELSE c2)
   \<sim>
   (IF b2 THEN (IF b1 THEN c11 ELSE c2) ELSE (IF b1 THEN c12 ELSE c2))"
by blast

lemma sim_while_cong_aux:
  "(WHILE b DO c,s) \<Rightarrow> t  \<Longrightarrow> c \<sim> c' \<Longrightarrow>  (WHILE b DO c',s) \<Rightarrow> t"
apply(induction "WHILE b DO c" s t arbitrary: b c rule: big_step_induct)
 apply blast
apply blast
done

lemma sim_while_cong: "c \<sim> c' \<Longrightarrow> WHILE b DO c \<sim> WHILE b DO c'"
by (metis sim_while_cong_aux)

text {* Command equivalence is an equivalence relation, i.e.\ it is
reflexive, symmetric, and transitive. Because we used an abbreviation
above, Isabelle derives this automatically. *}

lemma sim_refl:  "c \<sim> c" by simp
lemma sim_sym:   "(c \<sim> c') = (c' \<sim> c)" by auto
lemma sim_trans: "c \<sim> c' \<Longrightarrow> c' \<sim> c'' \<Longrightarrow> c \<sim> c''" by auto

subsection "Execution is deterministic"

text {* This proof is automatic. *}

theorem big_step_determ: "\<lbrakk> (c,s) \<Rightarrow> t; (c,s) \<Rightarrow> u \<rbrakk> \<Longrightarrow> u = t"
  by (induction arbitrary: u rule: big_step.induct) blast+

text {*
  This is the proof as you might present it in a lecture. The remaining
  cases are simple enough to be proved automatically:
*}
text_raw{*\snip{BigStepDetLong}{0}{2}{% *}
theorem
  "(c,s) \<Rightarrow> t  \<Longrightarrow>  (c,s) \<Rightarrow> t'  \<Longrightarrow>  t' = t"
proof (induction arbitrary: t' rule: big_step.induct)
  -- "the only interesting case, @{text WhileTrue}:"
  fix b c s s\<^sub>1 t t'
  -- "The assumptions of the rule:"
  assume "bval b s" and "(c,s) \<Rightarrow> s\<^sub>1" and "(WHILE b DO c,s\<^sub>1) \<Rightarrow> t"
  -- {* Ind.Hyp; note the @{text"\<And>"} because of arbitrary: *}
  assume IHc: "\<And>t'. (c,s) \<Rightarrow> t' \<Longrightarrow> t' = s\<^sub>1"
  assume IHw: "\<And>t'. (WHILE b DO c,s\<^sub>1) \<Rightarrow> t' \<Longrightarrow> t' = t"
  -- "Premise of implication:"
  assume "(WHILE b DO c,s) \<Rightarrow> t'"
  with `bval b s` obtain s\<^sub>1' where
      c: "(c,s) \<Rightarrow> s\<^sub>1'" and
      w: "(WHILE b DO c,s\<^sub>1') \<Rightarrow> t'"
    by auto
  from c IHc have "s\<^sub>1' = s\<^sub>1" by blast
  with w IHw show "t' = t" by blast
qed blast+ -- "prove the rest automatically"
text_raw{*}%endsnip*}

end