(*
   Authors: Asta Halkjær From, Agnes Moesgård Eschen & Jørgen Villadsen, DTU Compute
*)

theory System_H1 imports System_L1 begin

text \<open>System H from David Hilbert: Die logischen Grundlagen der Mathematik (1922)\<close>

text \<open>Derivations are taken from: On Axiom Systems of Propositional Calculi. I
                                  by Yasuyuki Imai and Kiyoshi Iseki (1965)\<close>

inductive H (\<open>\<HH>\<close>) where
  H_MP: \<open>\<HH> q\<close> if \<open>\<HH> p\<close> and \<open>\<HH> (p \<rightarrow> q)\<close> |
  H_1:  \<open>\<HH> (p \<rightarrow> (q \<rightarrow> p))\<close> |
  H_2:  \<open>\<HH> ((p \<rightarrow> (q \<rightarrow> r)) \<rightarrow> (q \<rightarrow> (p \<rightarrow> r)))\<close> |
  H_3:  \<open>\<HH> ((q \<rightarrow> r) \<rightarrow> ((p \<rightarrow> q) \<rightarrow> (p \<rightarrow> r)))\<close> |
  H_4:  \<open>\<HH> (p \<rightarrow> ((\<sim> p) \<rightarrow> q))\<close> |
  H_5:  \<open>\<HH> ((p \<rightarrow> q) \<rightarrow> (((\<sim> p) \<rightarrow> q) \<rightarrow> q))\<close>

lemma H_6: \<open>\<HH> ((p \<rightarrow> q) \<rightarrow> ((q \<rightarrow> r) \<rightarrow> (p \<rightarrow> r)))\<close>
  using H_2 H_3 H_MP by metis

lemma H_7: \<open>\<HH> (q \<rightarrow> (p \<rightarrow> p))\<close>
  using H_2 H_1 H_MP by metis

lemma H_8: \<open>\<HH> (p \<rightarrow> p)\<close>
  using H_1 H_7 H_MP by metis

lemma H_9: \<open>\<HH> (((\<sim> p) \<rightarrow> p) \<rightarrow> p)\<close>
  using H_5 H_8 H_MP by metis

theorem H_iff_L1: \<open>\<HH> p \<longleftrightarrow> \<turnstile> p\<close>
proof
  have L1_H_1: \<open>\<turnstile> (p \<rightarrow> (q \<rightarrow> p))\<close> for p q
    using L1_completeness by simp
  have L1_H_2: \<open>\<turnstile> ((p \<rightarrow> (q \<rightarrow> r)) \<rightarrow> (q \<rightarrow> (p \<rightarrow> r)))\<close> for p q r
    using L1_completeness by simp
  have L1_H_3: \<open>\<turnstile> ((q \<rightarrow> r) \<rightarrow> ((p \<rightarrow> q) \<rightarrow> (p \<rightarrow> r)))\<close> for p q r
    using L1_completeness by simp
  have L1_H_4: \<open>\<turnstile> (p \<rightarrow> ((\<sim> p) \<rightarrow> q))\<close> for p q
    using L1_completeness by simp
  have L1_H_5: \<open>\<turnstile> ((p \<rightarrow> q) \<rightarrow> (((\<sim> p) \<rightarrow> q) \<rightarrow> q))\<close> for p q
    using L1_completeness by simp
  show \<open>\<turnstile> p\<close> if \<open>\<HH> p\<close>
    using that by (induct) (metis MP, metis L1_H_1, metis L1_H_2,
        metis L1_H_3, metis L1_H_4, metis L1_H_5)
  show \<open>\<HH> p\<close> if \<open>\<turnstile> p\<close>
    using that by (induct) (metis H_MP, metis H_6, metis H_9, metis H_4)
qed

theorem H_soundness: \<open>\<HH> p \<Longrightarrow> I \<Turnstile> p\<close>
  by (induct rule: H.induct) auto

theorem H_completeness: \<open>\<forall>I. (I \<Turnstile> p) \<Longrightarrow> \<HH> p\<close>
  using H_iff_L1 by (simp add: L1_completeness)

section \<open>Soundness and Completeness\<close>

theorem main: \<open>valid p = \<HH> p\<close>
  unfolding valid_def using H_soundness H_completeness by blast

lemmas H1 = H.intros main

end


(*  Title:      HOL/HOLCF/IOA/NTP/Multiset.thy
    Author:     Tobias Nipkow & Konrad Slind
*)

section \<open>Axiomatic multisets\<close>

theory Multiset
imports Lemmas
begin

typedecl
  'a multiset

consts

  emptym :: "'a multiset"                        ("{|}")
  addm   :: "['a multiset, 'a] => 'a multiset"
  delm   :: "['a multiset, 'a] => 'a multiset"
  countm :: "['a multiset, 'a => bool] => nat"
  count  :: "['a multiset, 'a] => nat"

axiomatization where

delm_empty_def:
  "delm {|} x = {|}" and

delm_nonempty_def:
  "delm (addm M x) y == (if x=y then M else addm (delm M y) x)" and

countm_empty_def:
   "countm {|} P == 0" and

countm_nonempty_def:
   "countm (addm M x) P == countm M P + (if P x then Suc 0 else 0)" and

count_def:
   "count M x == countm M (%y. y = x)" and

"induction":
   "\<And>P M. [| P({|}); !!M x. P(M) ==> P(addm M x) |] ==> P(M)"

lemma count_empty:
   "count {|} x = 0"
  by (simp add: Multiset.count_def Multiset.countm_empty_def)

lemma count_addm_simp:
     "count (addm M x) y = (if y=x then Suc(count M y) else count M y)"
  by (simp add: Multiset.count_def Multiset.countm_nonempty_def)

lemma count_leq_addm: "count M y <= count (addm M x) y"
  by (simp add: count_addm_simp)

lemma count_delm_simp:
     "count (delm M x) y = (if y=x then count M y - 1 else count M y)"
apply (unfold Multiset.count_def)
apply (rule_tac M = "M" in Multiset.induction)
apply (simp (no_asm_simp) add: Multiset.delm_empty_def Multiset.countm_empty_def)
apply (simp add: Multiset.delm_nonempty_def Multiset.countm_nonempty_def)
apply safe
apply simp
done

lemma countm_props: "\<And>M. (\<forall>x. P(x) \<longrightarrow> Q(x)) \<Longrightarrow> (countm M P \<le> countm M Q)"
apply (rule_tac M = "M" in Multiset.induction)
 apply (simp (no_asm) add: Multiset.countm_empty_def)
apply (simp (no_asm) add: Multiset.countm_nonempty_def)
apply auto
done

lemma countm_spurious_delm: "!!P. ~P(obj) ==> countm M P = countm (delm M obj) P"
  apply (rule_tac M = "M" in Multiset.induction)
  apply (simp (no_asm) add: Multiset.delm_empty_def Multiset.countm_empty_def)
  apply (simp (no_asm_simp) add: Multiset.countm_nonempty_def Multiset.delm_nonempty_def)
  done

lemma pos_count_imp_pos_countm [rule_format (no_asm)]: "!!P. P(x) ==> 0<count M x --> countm M P > 0"
  apply (rule_tac M = "M" in Multiset.induction)
  apply (simp (no_asm) add: Multiset.delm_empty_def Multiset.count_def Multiset.countm_empty_def)
  apply (simp add: Multiset.count_def Multiset.delm_nonempty_def Multiset.countm_nonempty_def)
  done

lemma countm_done_delm:
   "!!P. P(x) ==> 0<count M x --> countm (delm M x) P = countm M P - 1"
  apply (rule_tac M = "M" in Multiset.induction)
  apply (simp (no_asm) add: Multiset.delm_empty_def Multiset.countm_empty_def)
  apply (simp (no_asm_simp) add: count_addm_simp Multiset.delm_nonempty_def Multiset.countm_nonempty_def pos_count_imp_pos_countm)
  apply auto
  done

declare count_addm_simp [simp] count_delm_simp [simp]
  Multiset.countm_empty_def [simp] Multiset.delm_empty_def [simp] count_empty [simp]

end


theory Chapter4
imports Main Chapter3
begin

(** Chapter 4 Logic and Proof Beyond Equality **)

(* Formulas are terms of type bool.

   The impliation \<Longrightarrow> is part of the Isabelle framework and should be used to structure theorems and
   proofs.

   There's also a formula for implication: \<longrightarrow>. It's part of HOL.

   Both \<Longrightarrow> and \<longrightarrow> are logically equivalent, but \<Longrightarrow> should be preferred in proofs because of its
   special treatment by Isabelle. Theorems must be of the form \<lbrakk> A\<^sub>1; A\<^sub>2; ...; A\<^sub>n \<rbrakk> \<Rightarrow> A rather
   than A\<^sub>1 \<and> A\<^sub>2 \<and> ... \<and> A\<^sub>n \<longrightarrow> A.
*)

(* Exercise 4.1 *)

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

fun set :: "'a tree \<Rightarrow> 'a set" where
"set Tip                 = {}" |
"set (Node x left right) = {x} \<union> set left \<union> set right"

datatype 'a bounds = Bounds 'a 'a 'a

fun element :: "'a bounds \<Rightarrow> 'a" where
"element (Bounds x _ _) = x"

fun lower_bound :: "'a bounds \<Rightarrow> 'a" where
"lower_bound (Bounds _ y _) = y"

fun upper_bound :: "'a bounds \<Rightarrow> 'a" where
"upper_bound (Bounds _ _ z) = z"

fun tree_lower_bound :: "'a \<Rightarrow> ('a bounds) tree \<Rightarrow> 'a" where
"tree_lower_bound x Tip          = x" |
"tree_lower_bound _ (Node b _ _) = lower_bound b"

fun tree_upper_bound :: "'a \<Rightarrow> ('a bounds) tree \<Rightarrow> 'a" where
"tree_upper_bound x Tip          = x" |
"tree_upper_bound _ (Node b _ _) = upper_bound b"

fun annotate_with_bounds :: "'a tree \<Rightarrow> ('a bounds) tree" where
"annotate_with_bounds Tip                 = Tip" |
"annotate_with_bounds (Node x left right) =
 (let left'  = annotate_with_bounds left;
      right' = annotate_with_bounds right
  in  Node (Bounds x (tree_lower_bound x left') (tree_upper_bound x right')) left' right')"

fun is_ordered :: "(int bounds) tree \<Rightarrow> bool" where
"is_ordered Tip = True" |
"is_ordered (Node b left right) =
 (let elem = element b in
  is_ordered left \<and>
  is_ordered right \<and>
  elem \<ge> tree_upper_bound elem left \<and>
  elem \<le> tree_lower_bound elem right)"

fun ord :: "int tree \<Rightarrow> bool" where
"ord t = is_ordered (annotate_with_bounds t)"

fun ins :: "int \<Rightarrow> int tree \<Rightarrow> int tree" where
"ins x Tip                 = Node x Tip Tip" |
"ins x (Node y left right) =
 (if x < y
  then Node y (ins x left) right
  else if x = y
  then Node y left right
  else Node y left (ins x right))"

theorem ins_adds_element : "set (ins x t) = {x} \<union> set t"
apply(induction t)
apply(auto)
done

lemma ins_maintains_lower_bound :
  "tree_lower_bound d (annotate_with_bounds t) \<ge> y \<Longrightarrow>
   x \<ge> y \<Longrightarrow>
   d \<ge> y \<Longrightarrow>
   tree_lower_bound d (annotate_with_bounds (ins x t)) \<ge> y"
apply(induction t arbitrary: d)
apply(simp_all)
apply(auto simp add: Let_def)
done

lemma ins_maintains_upper_bound :
  "tree_upper_bound d (annotate_with_bounds t) \<le> y \<Longrightarrow>
   x \<le> y \<Longrightarrow>
   d \<le> y \<Longrightarrow>
   tree_upper_bound d (annotate_with_bounds (ins x t)) \<le> y"
apply(induction t arbitrary: d)
apply(simp_all)
apply(auto simp add: Let_def)
done

theorem ins_preserves_ordering : "ord t \<Longrightarrow> ord (ins x t)"
apply(induction t)
apply(auto simp add: Let_def ins_maintains_lower_bound ins_maintains_upper_bound)
done

(** Section 4.5 Inductive definitions **)

inductive ev :: "nat \<Rightarrow> bool" where
ev0  : "ev 0" |
evSS : "ev n \<Longrightarrow> ev (Suc (Suc n))"

thm "evSS"

(* Inductive ev created two new "lemmas", ev0 and evSS, which can be used in proofs.

   They can be applied either in forward fashion *)

thm evSS[OF evSS[OF ev0]]

(* Or in backward way when prooving a lemma. E.g. *)

lemma "ev (Suc (Suc (Suc (Suc 0))))"
apply(rule evSS)
apply(rule evSS)
apply(rule ev0)
done

(* The "for r" part is merely a hint to Isabelle that r is a fixed parameter of star.
   This hint allows to generate simpler induction rule.
   *)
inductive star :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" for r where
refl : "star r x x" |
step : "r x y \<Longrightarrow> star r y z \<Longrightarrow> star r x z"

thm "star.induct"

lemma star_trans : "star r a b \<Longrightarrow> star r b c \<Longrightarrow> star r a c"
apply(induction rule: star.induct)
apply(assumption) (* Prove first case "star r x c \<Longrightarrow> star r x c" *)
apply(metis step)
done

(* Exercise 4.2 *)

inductive palindrome :: "'a list \<Rightarrow> bool" where
pempty     : "palindrome []"  |
psingleton : "palindrome [x]" |
pstep      : "palindrome xs \<Longrightarrow> palindrome (x # xs @ [x])"

theorem palindrome_reverse : "palindrome xs \<Longrightarrow> rev xs = xs"
apply(induction rule: palindrome.induct)
apply(simp_all)
done

(* Exercise 4.3 *)

inductive star' :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" for r where
refl' : "star' r x x" |
step' : "star' r x y \<Longrightarrow> r y z \<Longrightarrow> star' r x z"

thm "star'.induct"
thm "refl'"
thm "step'"
thm step'[OF refl']
thm step'[OF step'[OF refl']]
thm "star'.intros"

lemma star'_singleton : "r x y \<Longrightarrow> star' r x y"
(*apply(metis step' refl')*)
apply(rule step'[OF refl'])
apply(assumption)
done

lemma ext_star'_from_left : "star' r y z \<Longrightarrow> r x y \<Longrightarrow> star' r x z"
apply(induction rule: star'.induct)
apply(rule star'_singleton)
apply(assumption)
apply(simp)
apply(metis step')
done

theorem star_implies_star' : "star r a b \<Longrightarrow> star' r a b"
apply(induction rule: star.induct)
apply(rule refl')
apply(simp add: step ext_star'_from_left)
done

lemma star_singleton : "r a b \<Longrightarrow> star r a b"
by(metis step refl)

lemma ext_star_from_right : "star r a b \<Longrightarrow> r b c \<Longrightarrow> star r a c"
apply(induction rule: star.induct)
apply(rule star_singleton)
apply(assumption)
apply(simp)
apply(metis step)
done

theorem star'_implies_star : "star' r a b \<Longrightarrow> star r a b"
apply(induction rule: star'.induct)
apply(rule refl)
apply(simp add: step ext_star_from_right)
done

(* Exercise 4.4 *)

value "Suc"

inductive iter :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" for r where
irefl : "iter r 0 x x" |
istep : "r x y \<Longrightarrow> iter r n y z \<Longrightarrow> iter r (Suc n) x z"

thm "iter.induct"

theorem star_implies_iter : "star r x y \<Longrightarrow> \<exists> n. iter r n x y"
apply(induction rule: star.induct)
apply(metis irefl)
apply(metis istep)
done

(* Exercise 4.5 *)

datatype alpha = a | b

inductive S :: "alpha list \<Rightarrow> bool" where
emptyS     : "S []"                    |
balanceS   : "S s \<Longrightarrow> S (a # s @ [b])" |
duplicateS : "S x \<Longrightarrow> S y \<Longrightarrow> S (x @ y)"

inductive T :: "alpha list \<Rightarrow> bool" where
emptyT   : "T []" |
balanceT : "T x \<Longrightarrow> T y \<Longrightarrow> T (x @ [a] @ y @ [b])"

thm balanceT[OF emptyT]
lemmas balanceT' = balanceT[OF emptyT, simplified]

theorem T_implies_S : "T w \<Longrightarrow> S w"
apply(induction rule: T.induct)
apply(metis emptyS)
thm duplicateS[OF _ balanceS]
apply(simp)
apply(rule duplicateS[OF _ balanceS])
apply(assumption)
apply(assumption)
done

lemma balance_composite_first : "T (z @ x) \<Longrightarrow> T y \<Longrightarrow> T (z @ x @ [a] @ y @ [b])"
apply(simp)
apply(rule balanceT[of "z @ x" y, simplified])
apply(assumption)
apply(assumption)
done

lemma composite_T : "T y \<Longrightarrow> T x \<Longrightarrow> T (x @ y)"
apply(induction arbitrary: x rule: T.induct)
apply(simp)
apply(rename_tac x y z)
apply(rule balance_composite_first)
apply(auto)
done

theorem S_implies_T : "S w \<Longrightarrow> T w"
apply(induction rule: S.induct)
apply(metis emptyT)
apply(rule balanceT')
apply(assumption)
apply(rule composite_T)
apply(assumption)
apply(assumption)
done

(* Exercise 4.6 *)

inductive aval_rel :: "aexp \<Rightarrow> state \<Rightarrow> val \<Rightarrow> bool" (*for s :: state*) where
base_Nat  : "aval_rel (N n) s n"     |
base_Var  : "aval_rel (V v) s (s v)" |
step_Plus : "aval_rel e\<^sub>1 s n\<^sub>1 \<Longrightarrow> aval_rel e\<^sub>2 s n\<^sub>2 \<Longrightarrow> aval_rel (Plus e\<^sub>1 e\<^sub>2) s (n\<^sub>1 + n\<^sub>2)"

thm aval_rel.induct

theorem avar_rel_is_consistent_with_aval : "aval_rel e s v \<Longrightarrow> aval e s = v"
apply(induction rule: aval_rel.induct)
apply(auto)
done

thm "eq_commute"

theorem aval_is_consistent_with_aval_rel : "aval e s = v \<Longrightarrow> aval_rel e s v"
apply(induction e arbitrary: v)
apply(simp)
apply(rule base_Nat)
apply(simp)
apply(simp only: eq_commute)
apply(rule base_Var)
apply(simp only: eq_commute aval.simps)
apply(rule step_Plus)
apply(auto)
done

(* Exercise 4.7 *)

inductive ok :: "nat \<Rightarrow> instr list \<Rightarrow> nat \<Rightarrow> bool" where
ok_base       : "ok n [] n"                                                                |
ok_step_LOADI : "ok n is n'                                       \<Longrightarrow> ok n (is @ [LOADI k])   (Suc n')" |
ok_step_LOAD  : "ok n is n'                                       \<Longrightarrow> ok n (is @ [LOAD v])    (Suc n')" |
ok_step_ADD   : "ok n is\<^sub>1 (Suc n) \<Longrightarrow> ok (Suc n) is\<^sub>2 (Suc (Suc n)) \<Longrightarrow> ok n (is\<^sub>1 @ is\<^sub>2 @ [instr.ADD]) (Suc n)"

thm ok.induct

fun stack_length :: "stack \<Rightarrow> nat" where
"stack_length (Stack xs) = length xs"

lemma length_of_pushed_stack : "stack_length (push x stk) = Suc (stack_length stk)"
apply(induction stk)
apply(auto)
done

lemma length_of_twice_dropped_stack : "stack_length stk = Suc (Suc n) \<Longrightarrow> stack_length (drop2 stk) = n"
apply(induction stk rule: drop2.induct)
apply(simp_all)
done

theorem ok_correctly_computes_final_stack_size : "\<lbrakk> ok n is m; stack_length stk = n \<rbrakk> \<Longrightarrow> stack_length (exec is s stk) = m"
apply(induction arbitrary: stk rule: ok.induct)
apply(simp)
apply(simp_all only: exec_composite_list_of_instructions exec.simps exec1.simps)
apply(simp_all only: length_of_pushed_stack)
apply(simp only: length_of_twice_dropped_stack)
done

theorem comp_result_has_no_stack_underflow : "ok n (comp e) (Suc n)"
apply(induction e arbitrary: n)
apply(simp_all)
thm ok_step_LOADI[OF ok_base, simplified]
apply(rule ok_step_LOADI[OF ok_base, simplified])
apply(rule ok_step_LOAD[OF ok_base, simplified])
thm ok_step_ADD
apply(rule ok_step_ADD)
apply(assumption)
apply(assumption)
done

end


(* Author: Tobias Nipkow *)

section "Live Variable Analysis"

theory Live imports Vars Big_Step
begin

subsection "Liveness Analysis"

fun L :: "com \<Rightarrow> vname set \<Rightarrow> vname set" where
"L SKIP X = X" |
"L (x ::= a) X = vars a \<union> (X - {x})" |
"L (c\<^sub>1;; c\<^sub>2) X = L c\<^sub>1 (L c\<^sub>2 X)" |
"L (IF b THEN c\<^sub>1 ELSE c\<^sub>2) X = vars b \<union> L c\<^sub>1 X \<union> L c\<^sub>2 X" |
"L (WHILE b DO c) X = vars b \<union> X \<union> L c X"

value "show (L (''y'' ::= V ''z'';; ''x'' ::= Plus (V ''y'') (V ''z'')) {''x''})"

value "show (L (WHILE Less (V ''x'') (V ''x'') DO ''y'' ::= V ''z'') {''x''})"

fun "kill" :: "com \<Rightarrow> vname set" where
"kill SKIP = {}" |
"kill (x ::= a) = {x}" |
"kill (c\<^sub>1;; c\<^sub>2) = kill c\<^sub>1 \<union> kill c\<^sub>2" |
"kill (IF b THEN c\<^sub>1 ELSE c\<^sub>2) = kill c\<^sub>1 \<inter> kill c\<^sub>2" |
"kill (WHILE b DO c) = {}"

fun gen :: "com \<Rightarrow> vname set" where
"gen SKIP = {}" |
"gen (x ::= a) = vars a" |
"gen (c\<^sub>1;; c\<^sub>2) = gen c\<^sub>1 \<union> (gen c\<^sub>2 - kill c\<^sub>1)" |
"gen (IF b THEN c\<^sub>1 ELSE c\<^sub>2) = vars b \<union> gen c\<^sub>1 \<union> gen c\<^sub>2" |
"gen (WHILE b DO c) = vars b \<union> gen c"

lemma L_gen_kill: "L c X = gen c \<union> (X - kill c)"
by(induct c arbitrary:X) auto

lemma L_While_pfp: "L c (L (WHILE b DO c) X) \<subseteq> L (WHILE b DO c) X"
by(auto simp add:L_gen_kill)

lemma L_While_lpfp:
  "vars b \<union> X \<union> L c P \<subseteq> P \<Longrightarrow> L (WHILE b DO c) X \<subseteq> P"
by(simp add: L_gen_kill)

lemma L_While_vars: "vars b \<subseteq> L (WHILE b DO c) X"
by auto

lemma L_While_X: "X \<subseteq> L (WHILE b DO c) X"
by auto

text{* Disable L WHILE equation and reason only with L WHILE constraints *}
declare L.simps(5)[simp del]

subsection "Correctness"

theorem L_correct:
  "(c,s) \<Rightarrow> s'  \<Longrightarrow> s = t on L c X \<Longrightarrow>
  \<exists> t'. (c,t) \<Rightarrow> t' & s' = t' on X"
proof (induction arbitrary: X t rule: big_step_induct)
  case Skip then show ?case by auto
next
  case Assign then show ?case
    by (auto simp: ball_Un)
next
  case (Seq c1 s1 s2 c2 s3 X t1)
  from Seq.IH(1) Seq.prems obtain t2 where
    t12: "(c1, t1) \<Rightarrow> t2" and s2t2: "s2 = t2 on L c2 X"
    by simp blast
  from Seq.IH(2)[OF s2t2] obtain t3 where
    t23: "(c2, t2) \<Rightarrow> t3" and s3t3: "s3 = t3 on X"
    by auto
  show ?case using t12 t23 s3t3 by auto
next
  case (IfTrue b s c1 s' c2)
  hence "s = t on vars b" "s = t on L c1 X" by auto
  from  bval_eq_if_eq_on_vars[OF this(1)] IfTrue(1) have "bval b t" by simp
  from IfTrue.IH[OF `s = t on L c1 X`] obtain t' where
    "(c1, t) \<Rightarrow> t'" "s' = t' on X" by auto
  thus ?case using `bval b t` by auto
next
  case (IfFalse b s c2 s' c1)
  hence "s = t on vars b" "s = t on L c2 X" by auto
  from  bval_eq_if_eq_on_vars[OF this(1)] IfFalse(1) have "~bval b t" by simp
  from IfFalse.IH[OF `s = t on L c2 X`] obtain t' where
    "(c2, t) \<Rightarrow> t'" "s' = t' on X" by auto
  thus ?case using `~bval b t` by auto
next
  case (WhileFalse b s c)
  hence "~ bval b t"
    by (metis L_While_vars bval_eq_if_eq_on_vars set_mp)
  thus ?case by(metis WhileFalse.prems L_While_X big_step.WhileFalse set_mp)
next
  case (WhileTrue b s1 c s2 s3 X t1)
  let ?w = "WHILE b DO c"
  from `bval b s1` WhileTrue.prems have "bval b t1"
    by (metis L_While_vars bval_eq_if_eq_on_vars set_mp)
  have "s1 = t1 on L c (L ?w X)" using L_While_pfp WhileTrue.prems
    by (blast)
  from WhileTrue.IH(1)[OF this] obtain t2 where
    "(c, t1) \<Rightarrow> t2" "s2 = t2 on L ?w X" by auto
  from WhileTrue.IH(2)[OF this(2)] obtain t3 where "(?w,t2) \<Rightarrow> t3" "s3 = t3 on X"
    by auto
  with `bval b t1` `(c, t1) \<Rightarrow> t2` show ?case by auto
qed

subsection "Program Optimization"

text{* Burying assignments to dead variables: *}
fun bury :: "com \<Rightarrow> vname set \<Rightarrow> com" where
"bury SKIP X = SKIP" |
"bury (x ::= a) X = (if x \<in> X then x ::= a else SKIP)" |
"bury (c\<^sub>1;; c\<^sub>2) X = (bury c\<^sub>1 (L c\<^sub>2 X);; bury c\<^sub>2 X)" |
"bury (IF b THEN c\<^sub>1 ELSE c\<^sub>2) X = IF b THEN bury c\<^sub>1 X ELSE bury c\<^sub>2 X" |
"bury (WHILE b DO c) X = WHILE b DO bury c (L (WHILE b DO c) X)"

text{* We could prove the analogous lemma to @{thm[source]L_correct}, and the
proof would be very similar. However, we phrase it as a semantics
preservation property: *}

theorem bury_correct:
  "(c,s) \<Rightarrow> s'  \<Longrightarrow> s = t on L c X \<Longrightarrow>
  \<exists> t'. (bury c X,t) \<Rightarrow> t' & s' = t' on X"
proof (induction arbitrary: X t rule: big_step_induct)
  case Skip then show ?case by auto
next
  case Assign then show ?case
    by (auto simp: ball_Un)
next
  case (Seq c1 s1 s2 c2 s3 X t1)
  from Seq.IH(1) Seq.prems obtain t2 where
    t12: "(bury c1 (L c2 X), t1) \<Rightarrow> t2" and s2t2: "s2 = t2 on L c2 X"
    by simp blast
  from Seq.IH(2)[OF s2t2] obtain t3 where
    t23: "(bury c2 X, t2) \<Rightarrow> t3" and s3t3: "s3 = t3 on X"
    by auto
  show ?case using t12 t23 s3t3 by auto
next
  case (IfTrue b s c1 s' c2)
  hence "s = t on vars b" "s = t on L c1 X" by auto
  from  bval_eq_if_eq_on_vars[OF this(1)] IfTrue(1) have "bval b t" by simp
  from IfTrue.IH[OF `s = t on L c1 X`] obtain t' where
    "(bury c1 X, t) \<Rightarrow> t'" "s' =t' on X" by auto
  thus ?case using `bval b t` by auto
next
  case (IfFalse b s c2 s' c1)
  hence "s = t on vars b" "s = t on L c2 X" by auto
  from  bval_eq_if_eq_on_vars[OF this(1)] IfFalse(1) have "~bval b t" by simp
  from IfFalse.IH[OF `s = t on L c2 X`] obtain t' where
    "(bury c2 X, t) \<Rightarrow> t'" "s' = t' on X" by auto
  thus ?case using `~bval b t` by auto
next
  case (WhileFalse b s c)
  hence "~ bval b t" by (metis L_While_vars bval_eq_if_eq_on_vars set_mp)
  thus ?case
    by simp (metis L_While_X WhileFalse.prems big_step.WhileFalse set_mp)
next
  case (WhileTrue b s1 c s2 s3 X t1)
  let ?w = "WHILE b DO c"
  from `bval b s1` WhileTrue.prems have "bval b t1"
    by (metis L_While_vars bval_eq_if_eq_on_vars set_mp)
  have "s1 = t1 on L c (L ?w X)"
    using L_While_pfp WhileTrue.prems by blast
  from WhileTrue.IH(1)[OF this] obtain t2 where
    "(bury c (L ?w X), t1) \<Rightarrow> t2" "s2 = t2 on L ?w X" by auto
  from WhileTrue.IH(2)[OF this(2)] obtain t3
    where "(bury ?w X,t2) \<Rightarrow> t3" "s3 = t3 on X"
    by auto
  with `bval b t1` `(bury c (L ?w X), t1) \<Rightarrow> t2` show ?case by auto
qed

corollary final_bury_correct: "(c,s) \<Rightarrow> s' \<Longrightarrow> (bury c UNIV,s) \<Rightarrow> s'"
using bury_correct[of c s s' UNIV]
by (auto simp: fun_eq_iff[symmetric])

text{* Now the opposite direction. *}

lemma SKIP_bury[simp]:
  "SKIP = bury c X \<longleftrightarrow> c = SKIP | (EX x a. c = x::=a & x \<notin> X)"
by (cases c) auto

lemma Assign_bury[simp]: "x::=a = bury c X \<longleftrightarrow> c = x::=a & x : X"
by (cases c) auto

lemma Seq_bury[simp]: "bc\<^sub>1;;bc\<^sub>2 = bury c X \<longleftrightarrow>
  (EX c\<^sub>1 c\<^sub>2. c = c\<^sub>1;;c\<^sub>2 & bc\<^sub>2 = bury c\<^sub>2 X & bc\<^sub>1 = bury c\<^sub>1 (L c\<^sub>2 X))"
by (cases c) auto

lemma If_bury[simp]: "IF b THEN bc1 ELSE bc2 = bury c X \<longleftrightarrow>
  (EX c1 c2. c = IF b THEN c1 ELSE c2 &
     bc1 = bury c1 X & bc2 = bury c2 X)"
by (cases c) auto

lemma While_bury[simp]: "WHILE b DO bc' = bury c X \<longleftrightarrow>
  (EX c'. c = WHILE b DO c' & bc' = bury c' (L (WHILE b DO c') X))"
by (cases c) auto

theorem bury_correct2:
  "(bury c X,s) \<Rightarrow> s'  \<Longrightarrow> s = t on L c X \<Longrightarrow>
  \<exists> t'. (c,t) \<Rightarrow> t' & s' = t' on X"
proof (induction "bury c X" s s' arbitrary: c X t rule: big_step_induct)
  case Skip then show ?case by auto
next
  case Assign then show ?case
    by (auto simp: ball_Un)
next
  case (Seq bc1 s1 s2 bc2 s3 c X t1)
  then obtain c1 c2 where c: "c = c1;;c2"
    and bc2: "bc2 = bury c2 X" and bc1: "bc1 = bury c1 (L c2 X)" by auto
  note IH = Seq.hyps(2,4)
  from IH(1)[OF bc1, of t1] Seq.prems c obtain t2 where
    t12: "(c1, t1) \<Rightarrow> t2" and s2t2: "s2 = t2 on L c2 X" by auto
  from IH(2)[OF bc2 s2t2] obtain t3 where
    t23: "(c2, t2) \<Rightarrow> t3" and s3t3: "s3 = t3 on X"
    by auto
  show ?case using c t12 t23 s3t3 by auto
next
  case (IfTrue b s bc1 s' bc2)
  then obtain c1 c2 where c: "c = IF b THEN c1 ELSE c2"
    and bc1: "bc1 = bury c1 X" and bc2: "bc2 = bury c2 X" by auto
  have "s = t on vars b" "s = t on L c1 X" using IfTrue.prems c by auto
  from bval_eq_if_eq_on_vars[OF this(1)] IfTrue(1) have "bval b t" by simp
  note IH = IfTrue.hyps(3)
  from IH[OF bc1 `s = t on L c1 X`] obtain t' where
    "(c1, t) \<Rightarrow> t'" "s' =t' on X" by auto
  thus ?case using c `bval b t` by auto
next
  case (IfFalse b s bc2 s' bc1)
  then obtain c1 c2 where c: "c = IF b THEN c1 ELSE c2"
    and bc1: "bc1 = bury c1 X" and bc2: "bc2 = bury c2 X" by auto
  have "s = t on vars b" "s = t on L c2 X" using IfFalse.prems c by auto
  from bval_eq_if_eq_on_vars[OF this(1)] IfFalse(1) have "~bval b t" by simp
  note IH = IfFalse.hyps(3)
  from IH[OF bc2 `s = t on L c2 X`] obtain t' where
    "(c2, t) \<Rightarrow> t'" "s' =t' on X" by auto
  thus ?case using c `~bval b t` by auto
next
  case (WhileFalse b s c)
  hence "~ bval b t"
    by auto (metis L_While_vars bval_eq_if_eq_on_vars set_rev_mp)
  thus ?case using WhileFalse
    by auto (metis L_While_X big_step.WhileFalse set_mp)
next
  case (WhileTrue b s1 bc' s2 s3 w X t1)
  then obtain c' where w: "w = WHILE b DO c'"
    and bc': "bc' = bury c' (L (WHILE b DO c') X)" by auto
  from `bval b s1` WhileTrue.prems w have "bval b t1"
    by auto (metis L_While_vars bval_eq_if_eq_on_vars set_mp)
  note IH = WhileTrue.hyps(3,5)
  have "s1 = t1 on L c' (L w X)"
    using L_While_pfp WhileTrue.prems w by blast
  with IH(1)[OF bc', of t1] w obtain t2 where
    "(c', t1) \<Rightarrow> t2" "s2 = t2 on L w X" by auto
  from IH(2)[OF WhileTrue.hyps(6), of t2] w this(2) obtain t3
    where "(w,t2) \<Rightarrow> t3" "s3 = t3 on X"
    by auto
  with `bval b t1` `(c', t1) \<Rightarrow> t2` w show ?case by auto
qed

corollary final_bury_correct2: "(bury c UNIV,s) \<Rightarrow> s' \<Longrightarrow> (c,s) \<Rightarrow> s'"
using bury_correct2[of c UNIV]
by (auto simp: fun_eq_iff[symmetric])

corollary bury_sim: "bury c UNIV \<sim> c"
by(metis final_bury_correct final_bury_correct2)

end