(*  Title:      HOL/HOLCF/ex/Hoare.thy
    Author:     Franz Regensburger

Theory for an example by C.A.R. Hoare

p x = if b1 x
         then p (g x)
         else x fi

q x = if b1 x orelse b2 x
         then q (g x)
         else x fi

Prove: for all b1 b2 g .
            q o p  = q

In order to get a nice notation we fix the functions b1,b2 and g in the
signature of this example

*)

theory Hoare
imports HOLCF
begin

axiomatization
  b1 :: "'a \<rightarrow> tr" and
  b2 :: "'a \<rightarrow> tr" and
  g :: "'a \<rightarrow> 'a"

definition
  p :: "'a \<rightarrow> 'a" where
  "p = fix\<cdot>(LAM f. LAM x. If b1\<cdot>x then f\<cdot>(g\<cdot>x) else x)"

definition
  q :: "'a \<rightarrow> 'a" where
  "q = fix\<cdot>(LAM f. LAM x. If b1\<cdot>x orelse b2\<cdot>x then f\<cdot>(g\<cdot>x) else x)"

(* --------- pure HOLCF logic, some little lemmas ------ *)

lemma hoare_lemma2: "b \<noteq> TT \<Longrightarrow> b = FF \<or> b = UU"
apply (rule Exh_tr [THEN disjE])
apply blast+
done

lemma hoare_lemma3: "(\<forall>k. b1\<cdot>(iterate k\<cdot>g\<cdot>x) = TT) \<or> (\<exists>k. b1\<cdot>(iterate k\<cdot>g\<cdot>x) \<noteq> TT)"
apply blast
done

lemma hoare_lemma4: "(\<exists>k. b1\<cdot>(iterate k\<cdot>g\<cdot>x) \<noteq> TT) \<Longrightarrow>
  \<exists>k. b1\<cdot>(iterate k\<cdot>g\<cdot>x) = FF \<or> b1\<cdot>(iterate k\<cdot>g\<cdot>x) = UU"
apply (erule exE)
apply (rule exI)
apply (rule hoare_lemma2)
apply assumption
done

lemma hoare_lemma5: "\<lbrakk>(\<exists>k. b1\<cdot>(iterate k\<cdot>g\<cdot>x) \<noteq> TT);
    k = Least (\<lambda>n. b1\<cdot>(iterate n\<cdot>g\<cdot>x) \<noteq> TT)\<rbrakk> \<Longrightarrow>
  b1\<cdot>(iterate k\<cdot>g\<cdot>x) = FF \<or> b1\<cdot>(iterate k\<cdot>g\<cdot>x) = UU"
apply hypsubst
apply (rule hoare_lemma2)
apply (erule exE)
apply (erule LeastI)
done

lemma hoare_lemma6: "b = UU \<Longrightarrow> b \<noteq> TT"
apply hypsubst
apply (rule dist_eq_tr)
done

lemma hoare_lemma7: "b = FF \<Longrightarrow> b \<noteq> TT"
apply hypsubst
apply (rule dist_eq_tr)
done

lemma hoare_lemma8: "\<lbrakk>(\<exists>k. b1\<cdot>(iterate k\<cdot>g\<cdot>x) \<noteq> TT);
    k = Least (\<lambda>n. b1\<cdot>(iterate n\<cdot>g\<cdot>x) \<noteq> TT)\<rbrakk> \<Longrightarrow>
  \<forall>m. m < k \<longrightarrow> b1\<cdot>(iterate m\<cdot>g\<cdot>x) = TT"
apply hypsubst
apply (erule exE)
apply (intro strip)
apply (rule_tac p = "b1\<cdot>(iterate m\<cdot>g\<cdot>x)" in trE)
prefer 2 apply (assumption)
apply (rule le_less_trans [THEN less_irrefl [THEN notE]])
prefer 2 apply (assumption)
apply (rule Least_le)
apply (erule hoare_lemma6)
apply (rule le_less_trans [THEN less_irrefl [THEN notE]])
prefer 2 apply (assumption)
apply (rule Least_le)
apply (erule hoare_lemma7)
done

lemma hoare_lemma28: "f\<cdot>(y::'a) = (UU::tr) \<Longrightarrow> f\<cdot>UU = UU"
by (rule strictI)

(* ----- access to definitions ----- *)

lemma p_def3: "p\<cdot>x = If b1\<cdot>x then p\<cdot>(g\<cdot>x) else x"
apply (rule trans)
apply (rule p_def [THEN eq_reflection, THEN fix_eq3])
apply simp
done

lemma q_def3: "q\<cdot>x = If b1\<cdot>x orelse b2\<cdot>x then q\<cdot>(g\<cdot>x) else x"
apply (rule trans)
apply (rule q_def [THEN eq_reflection, THEN fix_eq3])
apply simp
done

(** --------- proofs about iterations of p and q ---------- **)

lemma hoare_lemma9: "(\<forall>m. m < Suc k \<longrightarrow> b1\<cdot>(iterate m\<cdot>g\<cdot>x) = TT) \<longrightarrow>
   p\<cdot>(iterate k\<cdot>g\<cdot>x) = p\<cdot>x"
apply (induct_tac k)
apply (simp (no_asm))
apply (simp (no_asm))
apply (intro strip)
apply (rule_tac s = "p\<cdot>(iterate n\<cdot>g\<cdot>x)" in trans)
apply (rule trans)
apply (rule_tac [2] p_def3 [symmetric])
apply (rule_tac s = "TT" and t = "b1\<cdot>(iterate n\<cdot>g\<cdot>x)" in ssubst)
apply (rule mp)
apply (erule spec)
apply (simp (no_asm) add: less_Suc_eq)
apply simp
apply (erule mp)
apply (intro strip)
apply (rule mp)
apply (erule spec)
apply (erule less_trans)
apply simp
done

lemma hoare_lemma24: "(\<forall>m. m < Suc k \<longrightarrow> b1\<cdot>(iterate m\<cdot>g\<cdot>x) = TT) \<longrightarrow>
  q\<cdot>(iterate k\<cdot>g\<cdot>x) = q\<cdot>x"
apply (induct_tac k)
apply (simp (no_asm))
apply (simp (no_asm) add: less_Suc_eq)
apply (intro strip)
apply (rule_tac s = "q\<cdot>(iterate n\<cdot>g\<cdot>x)" in trans)
apply (rule trans)
apply (rule_tac [2] q_def3 [symmetric])
apply (rule_tac s = "TT" and t = "b1\<cdot>(iterate n\<cdot>g\<cdot>x)" in ssubst)
apply blast
apply simp
apply (erule mp)
apply (intro strip)
apply (fast dest!: less_Suc_eq [THEN iffD1])
done

(* -------- results about p for case (\<exists>k. b1\<cdot>(iterate k\<cdot>g\<cdot>x) \<noteq> TT) ------- *)

lemma hoare_lemma10:
  "\<exists>k. b1\<cdot>(iterate k\<cdot>g\<cdot>x) \<noteq> TT
    \<Longrightarrow> Suc k = (LEAST n. b1\<cdot>(iterate n\<cdot>g\<cdot>x) \<noteq> TT) \<Longrightarrow> p\<cdot>(iterate k\<cdot>g\<cdot>x) = p\<cdot>x"
  by (rule hoare_lemma8 [THEN hoare_lemma9 [THEN mp]])

lemma hoare_lemma11: "(\<exists>n. b1\<cdot>(iterate n\<cdot>g\<cdot>x) \<noteq> TT) \<Longrightarrow>
  k = (LEAST n. b1\<cdot>(iterate n\<cdot>g\<cdot>x) \<noteq> TT) \<and> b1\<cdot>(iterate k\<cdot>g\<cdot>x) = FF
  \<longrightarrow> p\<cdot>x = iterate k\<cdot>g\<cdot>x"
apply (case_tac "k")
apply hypsubst
apply (simp (no_asm))
apply (intro strip)
apply (erule conjE)
apply (rule trans)
apply (rule p_def3)
apply simp
apply hypsubst
apply (intro strip)
apply (erule conjE)
apply (rule trans)
apply (erule hoare_lemma10 [symmetric])
apply assumption
apply (rule trans)
apply (rule p_def3)
apply (rule_tac s = "TT" and t = "b1\<cdot>(iterate nat\<cdot>g\<cdot>x)" in ssubst)
apply (rule hoare_lemma8 [THEN spec, THEN mp])
apply assumption
apply assumption
apply (simp (no_asm))
apply (simp (no_asm))
apply (rule trans)
apply (rule p_def3)
apply (simp (no_asm) del: iterate_Suc add: iterate_Suc [symmetric])
apply (erule_tac s = "FF" in ssubst)
apply simp
done

lemma hoare_lemma12: "(\<exists>n. b1\<cdot>(iterate n\<cdot>g\<cdot>x) \<noteq> TT) \<Longrightarrow>
  k = Least (\<lambda>n. b1\<cdot>(iterate n\<cdot>g\<cdot>x) \<noteq> TT) \<and> b1\<cdot>(iterate k\<cdot>g\<cdot>x) = UU
  \<longrightarrow> p\<cdot>x = UU"
apply (case_tac "k")
apply hypsubst
apply (simp (no_asm))
apply (intro strip)
apply (erule conjE)
apply (rule trans)
apply (rule p_def3)
apply simp
apply hypsubst
apply (simp (no_asm))
apply (intro strip)
apply (erule conjE)
apply (rule trans)
apply (rule hoare_lemma10 [symmetric])
apply assumption
apply assumption
apply (rule trans)
apply (rule p_def3)
apply (rule_tac s = "TT" and t = "b1\<cdot>(iterate nat\<cdot>g\<cdot>x)" in ssubst)
apply (rule hoare_lemma8 [THEN spec, THEN mp])
apply assumption
apply assumption
apply (simp (no_asm))
apply (simp)
apply (rule trans)
apply (rule p_def3)
apply simp
done

(* -------- results about p for case  (\<forall>k. b1\<cdot>(iterate k\<cdot>g\<cdot>x) = TT) ------- *)

lemma fernpass_lemma: "(\<forall>k. b1\<cdot>(iterate k\<cdot>g\<cdot>x) = TT) \<Longrightarrow> \<forall>k. p\<cdot>(iterate k\<cdot>g\<cdot>x) = UU"
apply (rule p_def [THEN eq_reflection, THEN def_fix_ind])
apply simp
apply simp
apply (simp (no_asm))
apply (rule allI)
apply (rule_tac s = "TT" and t = "b1\<cdot>(iterate k\<cdot>g\<cdot>x)" in ssubst)
apply (erule spec)
apply (simp)
apply (rule iterate_Suc [THEN subst])
apply (erule spec)
done

lemma hoare_lemma16: "(\<forall>k. b1\<cdot>(iterate k\<cdot>g\<cdot>x) = TT) \<Longrightarrow> p\<cdot>x = UU"
apply (rule_tac F1 = "g" and t = "x" in iterate_0 [THEN subst])
apply (erule fernpass_lemma [THEN spec])
done

(* -------- results about q for case  (\<forall>k. b1\<cdot>(iterate k\<cdot>g\<cdot>x) = TT) ------- *)

lemma hoare_lemma17: "(\<forall>k. b1\<cdot>(iterate k\<cdot>g\<cdot>x) = TT) \<Longrightarrow> \<forall>k. q\<cdot>(iterate k\<cdot>g\<cdot>x) = UU"
apply (rule q_def [THEN eq_reflection, THEN def_fix_ind])
apply simp
apply simp
apply (rule allI)
apply (simp (no_asm))
apply (rule_tac s = "TT" and t = "b1\<cdot>(iterate k\<cdot>g\<cdot>x)" in ssubst)
apply (erule spec)
apply (simp)
apply (rule iterate_Suc [THEN subst])
apply (erule spec)
done

lemma hoare_lemma18: "(\<forall>k. b1\<cdot>(iterate k\<cdot>g\<cdot>x) = TT) \<Longrightarrow> q\<cdot>x = UU"
apply (rule_tac F1 = "g" and t = "x" in iterate_0 [THEN subst])
apply (erule hoare_lemma17 [THEN spec])
done

lemma hoare_lemma19:
  "(\<forall>k. (b1::'a\<rightarrow>tr)\<cdot>(iterate k\<cdot>g\<cdot>x) = TT) \<Longrightarrow> b1\<cdot>(UU::'a) = UU \<or> (\<forall>y. b1\<cdot>(y::'a) = TT)"
apply (rule flat_codom)
apply (rule_tac t = "x" in iterate_0 [THEN subst])
apply (erule spec)
done

lemma hoare_lemma20: "(\<forall>y. b1\<cdot>(y::'a) = TT) \<Longrightarrow> \<forall>k. q\<cdot>(iterate k\<cdot>g\<cdot>(x::'a)) = UU"
apply (rule q_def [THEN eq_reflection, THEN def_fix_ind])
apply simp
apply simp
apply (rule allI)
apply (simp (no_asm))
apply (rule_tac s = "TT" and t = "b1\<cdot>(iterate k\<cdot>g\<cdot>(x::'a))" in ssubst)
apply (erule spec)
apply (simp)
apply (rule iterate_Suc [THEN subst])
apply (erule spec)
done

lemma hoare_lemma21: "(\<forall>y. b1\<cdot>(y::'a) = TT) \<Longrightarrow> q\<cdot>(x::'a) = UU"
apply (rule_tac F1 = "g" and t = "x" in iterate_0 [THEN subst])
apply (erule hoare_lemma20 [THEN spec])
done

lemma hoare_lemma22: "b1\<cdot>(UU::'a) = UU \<Longrightarrow> q\<cdot>(UU::'a) = UU"
apply (subst q_def3)
apply simp
done

(* -------- results about q for case (\<exists>k. b1\<cdot>(iterate k\<cdot>g\<cdot>x) \<noteq> TT) ------- *)

lemma hoare_lemma25: "\<exists>k. b1\<cdot>(iterate k\<cdot>g\<cdot>x) \<noteq> TT
  \<Longrightarrow> Suc k = (LEAST n. b1\<cdot>(iterate n\<cdot>g\<cdot>x) \<noteq> TT) \<Longrightarrow> q\<cdot>(iterate k\<cdot>g\<cdot>x) = q\<cdot>x"
  by (rule hoare_lemma8 [THEN hoare_lemma24 [THEN mp]])

lemma hoare_lemma26: "(\<exists>n. b1\<cdot>(iterate n\<cdot>g\<cdot>x) \<noteq> TT) \<Longrightarrow>
  k = Least (\<lambda>n. b1\<cdot>(iterate n\<cdot>g\<cdot>x) \<noteq> TT) \<and> b1\<cdot>(iterate k\<cdot>g\<cdot>x) = FF
  \<longrightarrow> q\<cdot>x = q\<cdot>(iterate k\<cdot>g\<cdot>x)"
apply (case_tac "k")
apply hypsubst
apply (intro strip)
apply (simp (no_asm))
apply hypsubst
apply (intro strip)
apply (erule conjE)
apply (rule trans)
apply (rule hoare_lemma25 [symmetric])
apply assumption
apply assumption
apply (rule trans)
apply (rule q_def3)
apply (rule_tac s = "TT" and t = "b1\<cdot>(iterate nat\<cdot>g\<cdot>x)" in ssubst)
apply (rule hoare_lemma8 [THEN spec, THEN mp])
apply assumption
apply assumption
apply (simp (no_asm))
apply (simp (no_asm))
done

lemma hoare_lemma27: "(\<exists>n. b1\<cdot>(iterate n\<cdot>g\<cdot>x) \<noteq> TT) \<Longrightarrow>
  k = Least(\<lambda>n. b1\<cdot>(iterate n\<cdot>g\<cdot>x) \<noteq> TT) \<and> b1\<cdot>(iterate k\<cdot>g\<cdot>x) = UU
  \<longrightarrow> q\<cdot>x = UU"
apply (case_tac "k")
apply hypsubst
apply (simp (no_asm))
apply (intro strip)
apply (erule conjE)
apply (subst q_def3)
apply (simp)
apply hypsubst
apply (simp (no_asm))
apply (intro strip)
apply (erule conjE)
apply (rule trans)
apply (rule hoare_lemma25 [symmetric])
apply assumption
apply assumption
apply (rule trans)
apply (rule q_def3)
apply (rule_tac s = "TT" and t = "b1\<cdot>(iterate nat\<cdot>g\<cdot>x)" in ssubst)
apply (rule hoare_lemma8 [THEN spec, THEN mp])
apply assumption
apply assumption
apply (simp (no_asm))
apply (simp)
apply (rule trans)
apply (rule q_def3)
apply (simp)
done

(* ------- (\<forall>k. b1\<cdot>(iterate k\<cdot>g\<cdot>x) = TT) \<Longrightarrow> q \<circ> p = q   ----- *)

lemma hoare_lemma23: "(\<forall>k. b1\<cdot>(iterate k\<cdot>g\<cdot>x) = TT) \<Longrightarrow> q\<cdot>(p\<cdot>x) = q\<cdot>x"
apply (subst hoare_lemma16)
apply assumption
apply (rule hoare_lemma19 [THEN disjE])
apply assumption
apply (simplesubst hoare_lemma18)
apply assumption
apply (simplesubst hoare_lemma22)
apply assumption
apply (rule refl)
apply (simplesubst hoare_lemma21)
apply assumption
apply (simplesubst hoare_lemma21)
apply assumption
apply (rule refl)
done

(* ------------  \<exists>k. b1\<cdot>(iterate k\<cdot>g\<cdot>x) \<noteq> TT \<Longrightarrow> q \<circ> p = q   ----- *)

lemma hoare_lemma29: "\<exists>k. b1\<cdot>(iterate k\<cdot>g\<cdot>x) \<noteq> TT \<Longrightarrow> q\<cdot>(p\<cdot>x) = q\<cdot>x"
apply (rule hoare_lemma5 [THEN disjE])
apply assumption
apply (rule refl)
apply (subst hoare_lemma11 [THEN mp])
apply assumption
apply (rule conjI)
apply (rule refl)
apply assumption
apply (rule hoare_lemma26 [THEN mp, THEN subst])
apply assumption
apply (rule conjI)
apply (rule refl)
apply assumption
apply (rule refl)
apply (subst hoare_lemma12 [THEN mp])
apply assumption
apply (rule conjI)
apply (rule refl)
apply assumption
apply (subst hoare_lemma22)
apply (subst hoare_lemma28)
apply assumption
apply (rule refl)
apply (rule sym)
apply (subst hoare_lemma27 [THEN mp])
apply assumption
apply (rule conjI)
apply (rule refl)
apply assumption
apply (rule refl)
done

(* ------ the main proof q \<circ> p = q ------ *)

theorem hoare_main: "q oo p = q"
apply (rule cfun_eqI)
apply (subst cfcomp2)
apply (rule hoare_lemma3 [THEN disjE])
apply (erule hoare_lemma23)
apply (erule hoare_lemma29)
done

end


(*<*)
theory Restrict_Bounds_Impl
imports Restrict_Bounds
begin
(*>*)

section \<open>Refining the Non-Deterministic @{term simplification.rb} Function\<close>

fun gen_size where
  "gen_size (Bool b) = 1"
| "gen_size (Eq x t) = 1"
| "gen_size (Pred p ts) = 1"
| "gen_size (Neg (Neg Q)) = Suc (gen_size Q)"
| "gen_size (Neg (Conj Q1 Q2)) = Suc (Suc (gen_size (Neg Q1) + gen_size (Neg Q2)))"
| "gen_size (Neg (Disj Q1 Q2)) = Suc (Suc (gen_size (Neg Q1) + gen_size (Neg Q2)))"
| "gen_size (Neg Q) = Suc (gen_size Q)"
| "gen_size (Conj Q1 Q2) = Suc (gen_size Q1 + gen_size Q2)"
| "gen_size (Disj Q1 Q2) = Suc (gen_size Q1 + gen_size Q2)"
| "gen_size (Exists x Q) = Suc (gen_size Q)"

function (sequential) gen_impl where
  "gen_impl x (Bool False) = [{}]"
| "gen_impl x (Bool True) = []"
| "gen_impl x (Eq y (Const c)) = (if x = y then [{Eq y (Const c)}] else [])"
| "gen_impl x (Eq y (Var z)) = []"
| "gen_impl x (Pred p ts) = (if x \<in> fv_terms_set ts then [{Pred p ts}] else [])"
| "gen_impl x (Neg (Neg Q)) = gen_impl x Q"
| "gen_impl x (Neg (Conj Q1 Q2)) = gen_impl x (Disj (Neg Q1) (Neg Q2))"
| "gen_impl x (Neg (Disj Q1 Q2)) = gen_impl x (Conj (Neg Q1) (Neg Q2))"
| "gen_impl x (Neg _) = []"
| "gen_impl x (Disj Q1 Q2) =  [G1 \<union> G2. G1 \<leftarrow> gen_impl x Q1, G2 \<leftarrow> gen_impl x Q2]"
| "gen_impl x (Conj Q1 (y \<approx> z)) = (if x = y then List.union (gen_impl x Q1) (map (image (\<lambda>Q. cp (Q[z \<^bold>\<rightarrow> x]))) (gen_impl z Q1))
     else if x = z then List.union (gen_impl x Q1) (map (image (\<lambda>Q. cp (Q[y \<^bold>\<rightarrow> x]))) (gen_impl y Q1))
     else gen_impl x Q1)"|
 "gen_impl x (Conj Q1 Q2) = List.union (gen_impl x Q1) (gen_impl x Q2)"
| "gen_impl x (Exists y Q) = (if x = y then [] else map (image (exists y)) (gen_impl x Q))"
  by pat_completeness auto
termination by (relation "measure (\<lambda>(x, Q). gen_size Q)") simp_all

lemma gen_impl_gen: "G \<in> set (gen_impl x Q) \<Longrightarrow> gen x Q G"
  by (induct x Q arbitrary: G rule: gen_impl.induct)
    (auto 5 2 simp: fv_terms_set_def intro: gen.intros simp: image_iff split: if_splits)

lemma gen_gen_impl: "gen x Q G \<Longrightarrow> G \<in> set (gen_impl x Q)"
proof (induct x Q G rule: gen.induct)
  case (7 x Q1 G Q2)
  then show ?case
  proof (cases Q2)
    case (Eq x t)
    with 7 show ?thesis
      by (cases t) auto
  qed auto
qed (auto elim!: ap.cases simp: image_iff)

lemma set_gen_impl: "set (gen_impl x Q) = {G. gen x Q G}"
  by (auto simp: gen_impl_gen gen_gen_impl)

definition "flat xss = fold List.union xss []"

(*much faster than fun*)
primrec cov_impl where
  "cov_impl x (Bool b) = [{}]"
| "cov_impl x (Eq y t) = (case t of
      Const c \<Rightarrow> [if x = y then {Eq y (Const c)} else {}]
    | Var z \<Rightarrow> [if x = y \<and> x \<noteq> z then {x \<approx> z}
                else if x = z \<and> x \<noteq> y then {x \<approx> y}
                else {}])"
| "cov_impl x (Pred p ts) = [if x \<in> fv_terms_set ts then {Pred p ts} else {}]"
| "cov_impl x (Neg Q) = cov_impl x Q"
| "cov_impl x (Disj Q1 Q2) = (case (cp (Q1 \<^bold>\<bottom> x), cp (Q2 \<^bold>\<bottom> x)) of
     (Bool True, Bool True) \<Rightarrow> List.union (cov_impl x Q1) (cov_impl x Q2)
   | (Bool True, _) \<Rightarrow> cov_impl x Q1
   | (_, Bool True) \<Rightarrow> cov_impl x Q2
   | (_, _) \<Rightarrow> [G1 \<union> G2. G1 \<leftarrow> cov_impl x Q1, G2 \<leftarrow> cov_impl x Q2])"
| "cov_impl x (Conj Q1 Q2) = (case (cp (Q1 \<^bold>\<bottom> x), cp (Q2 \<^bold>\<bottom> x)) of
     (Bool False, Bool False) \<Rightarrow> List.union (cov_impl x Q1) (cov_impl x Q2)
   | (Bool False, _) \<Rightarrow> cov_impl x Q1
   | (_, Bool False) \<Rightarrow> cov_impl x Q2
   | (_, _) \<Rightarrow> [G1 \<union> G2. G1 \<leftarrow> cov_impl x Q1, G2 \<leftarrow> cov_impl x Q2])"
| "cov_impl x (Exists y Q) = (if x = y then [{}] else flat (map (\<lambda>G.
     (if x \<approx> y \<in> G then [exists y ` (G - {x \<approx> y}) \<union> (\<lambda>Q. cp (Q[y \<^bold>\<rightarrow> x])) ` G'. G' \<leftarrow> gen_impl y Q]
      else [exists y ` G])) (cov_impl x Q)))"

lemma union_empty_iff: "List.union xs ys = [] \<longleftrightarrow> xs = [] \<and> ys = []"
  by (induct xs arbitrary: ys) (force simp: List.union_def List.insert_def)+

lemma fold_union_empty_iff: "fold List.union xss ys = [] \<longleftrightarrow> (\<forall>xs \<in> set xss. xs = []) \<and> ys = []"
  by (induct xss arbitrary: ys) (auto simp: union_empty_iff)

lemma flat_empty_iff: "flat xss = [] \<longleftrightarrow> (\<forall>xs \<in> set xss. xs = [])"
  by (auto simp: flat_def fold_union_empty_iff)

lemma set_fold_union: "set (fold List.union xss ys) = (\<Union> (set ` set xss)) \<union> set ys"
  by (induct xss arbitrary: ys) auto

lemma set_flat: "set (flat xss) = \<Union> (set ` set xss)"
  unfolding flat_def by (auto simp: set_fold_union)

lemma rrb_cov_impl: "rrb Q \<Longrightarrow> cov_impl x Q \<noteq> []"
proof (induct Q arbitrary: x)
  case (Exists y Q)
  then show ?case
    by (cases "\<exists>G \<in> set (cov_impl x Q). x \<approx> y \<in> G")
      (auto simp: flat_empty_iff image_iff dest: gen_gen_impl intro!: UnI1 bexI[rotated])
qed (auto split: term.splits fmla.splits bool.splits simp: union_empty_iff)

lemma cov_Eq_self: "cov x (y \<approx> y) {}"
  by (metis Un_absorb cov.Eq_self cov.nonfree fv.simps(3) fv_term_set.simps(1) singletonD)

lemma cov_impl_cov: "G \<in> set (cov_impl x Q) \<Longrightarrow> cov x Q G"
proof (induct Q arbitrary: x G)
  case (Eq y t)
  then show ?case
    by (auto simp: cov_Eq_self intro: cov.intros ap.intros split: term.splits)
qed (auto simp: set_flat set_gen_impl intro: cov.intros ap.intros
  split: term.splits fmla.splits bool.splits if_splits)

definition "fixbound_impl \<Q> x = filter (\<lambda>Q. x \<in> fv Q \<and> gen_impl x Q = []) (sorted_list_of_set \<Q>)"

lemma set_fixbound_impl: "finite \<Q> \<Longrightarrow> set (fixbound_impl \<Q> x) = fixbound \<Q> x"
  by (auto simp: fixbound_def nongens_def fixbound_impl_def set_gen_impl
    dest: arg_cong[of _ _ set] simp flip: List.set_empty)

lemma fixbound_empty_iff: "finite \<Q> \<Longrightarrow> fixbound \<Q> x \<noteq> {} \<longleftrightarrow> fixbound_impl \<Q> x \<noteq> []"
  by (auto simp: set_fixbound_impl dest: arg_cong[of _ _ set] simp flip: List.set_empty)

lemma fixbound_impl_hd_in: "finite \<Q> \<Longrightarrow> fixbound_impl \<Q> x = y # ys \<Longrightarrow> y \<in> \<Q>"
  by (auto simp: fixbound_impl_def dest!: arg_cong[of _ _ set])

fun (in simplification) rb_impl :: "('a :: {infinite, linorder}, 'b :: linorder) fmla \<Rightarrow> ('a, 'b) fmla nres" where
  "rb_impl (Neg Q) = do { Q' \<leftarrow> rb_impl Q; RETURN (simp (Neg Q'))}"
| "rb_impl (Disj Q1 Q2) = do { Q1' \<leftarrow> rb_impl Q1; Q2' \<leftarrow> rb_impl Q2; RETURN (simp (Disj Q1' Q2'))}"
| "rb_impl (Conj Q1 Q2) = do { Q1' \<leftarrow> rb_impl Q1; Q2' \<leftarrow> rb_impl Q2; RETURN (simp (Conj Q1' Q2'))}"
| "rb_impl (Exists x Q) = do {
    Q' \<leftarrow> rb_impl Q;
    \<Q> \<leftarrow> WHILE
      (\<lambda>\<Q>. fixbound_impl \<Q> x \<noteq> []) (\<lambda>\<Q>. do {
        Qfix \<leftarrow> RETURN (hd (fixbound_impl \<Q> x));
        G \<leftarrow> RETURN (hd (cov_impl x Qfix));
        RETURN (\<Q> - {Qfix} \<union>
          {simp (Conj Qfix (DISJ (qps G)))} \<union>
          (\<Union>y \<in> eqs x G. {cp (Qfix[x \<^bold>\<rightarrow> y])}) \<union>
          {cp (Qfix \<^bold>\<bottom> x)})})
      (flat_Disj Q');
    RETURN (simp (DISJ (exists x ` \<Q>)))}"
| "rb_impl Q = do { RETURN (simp Q) }"

lemma (in simplification) rb_impl_refines_rb: "rb_impl Q \<le> rb Q"
  apply (induct Q)
  apply (unfold rb.simps rb_impl.simps)
  apply refine_mono
  apply refine_mono
  apply refine_mono
  apply refine_mono
  apply refine_mono
  apply refine_mono
  apply refine_mono
  subgoal for x Q' Q
    apply (rule order_trans[OF WHILE_le_WHILEI[where I="rb_INV x Q"]])
    apply (rule order_trans[OF WHILEI_le_WHILEIT])
    apply (rule WHILEIT_refine[OF _ _ _ refine_IdI, THEN refine_IdD])
       apply (simp_all add: fixbound_empty_iff) [3]
    apply refine_mono
      apply (auto simp flip: set_fixbound_impl simp: neq_Nil_conv fixbound_impl_hd_in
        intro!: cov_impl_cov rrb_cov_impl hd_in_set rb_INV_rrb)
    done
  done

fun (in simplification) rb_impl_det :: "('a :: {infinite, linorder}, 'b :: linorder) fmla \<Rightarrow> ('a, 'b) fmla dres" where
  "rb_impl_det (Neg Q) = do { Q' \<leftarrow> rb_impl_det Q; dRETURN (simp (Neg Q'))}"
| "rb_impl_det (Disj Q1 Q2) = do { Q1' \<leftarrow> rb_impl_det Q1; Q2' \<leftarrow> rb_impl_det Q2; dRETURN (simp (Disj Q1' Q2'))}"
| "rb_impl_det (Conj Q1 Q2) = do { Q1' \<leftarrow> rb_impl_det Q1; Q2' \<leftarrow> rb_impl_det Q2; dRETURN (simp (Conj Q1' Q2'))}"
| "rb_impl_det (Exists x Q) = do {
    Q' \<leftarrow> rb_impl_det Q;
    \<Q> \<leftarrow> dWHILE
      (\<lambda>\<Q>. fixbound_impl \<Q> x \<noteq> []) (\<lambda>\<Q>. do {
        Qfix \<leftarrow> dRETURN (hd (fixbound_impl \<Q> x));
        G \<leftarrow> dRETURN (hd (cov_impl x Qfix));
        dRETURN (\<Q> - {Qfix} \<union>
          {simp (Conj Qfix (DISJ (qps G)))} \<union>
          (\<Union>y \<in> eqs x G. {cp (Qfix[x \<^bold>\<rightarrow> y])}) \<union>
          {cp (Qfix \<^bold>\<bottom> x)})})
      (flat_Disj Q');
    dRETURN (simp (DISJ (exists x ` \<Q>)))}"
| "rb_impl_det Q = do { dRETURN (simp Q) }"

lemma (in simplification) rb_impl_det_refines_rb_impl: "nres_of (rb_impl_det Q) \<le> rb_impl Q"
  by (induct Q; unfold rb_impl.simps rb_impl_det.simps) refine_transfer+

lemmas (in simplification) RB_correct =
  rb_impl_det_refines_rb_impl[THEN order_trans, OF
  rb_impl_refines_rb[THEN order_trans, OF
  rb_correct]]

(*<*)
end
(*>*)


theory regexp_RecPlus
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

datatype 'a list = Nil2 | Cons2 "'a" "'a list"

datatype A = X | Y

datatype R
  = Nil2 | Eps | Atom "A" | Plus "R" "R" | Seq "R" "R" | Star "R"

fun seq :: "R => R => R" where
"seq x y =
   case x of
     | other =>
         case y of
           | other =>
               case x of
                 | other =>
                     case y of
                       | other => Seq x y
                       | Eps => x
                     end
                 | Eps => y
               end
           | Nil2 => y
         end
     | Nil2 => x
   end"

fun plus :: "R => R => R" where
"plus x y =
   case x of
     | other =>
         case y of
           | other => Plus x y
           | Nil2 => x
         end
     | Nil2 => y
   end"

fun or2 :: "bool => bool => bool" where
"or2 True y = True"
| "or2 False y = y"

fun eqA :: "A => A => bool" where
"eqA (X) y = False"
| "eqA (Y) (X) = False"
| "eqA (Y) (Y) = True"

fun and2 :: "bool => bool => bool" where
"and2 True y = y"
| "and2 False y = False"

fun eps :: "R => bool" where
"eps x =
   case x of
     | other => False
     | Eps => True
     | Plus p q => or2 (eps p) (eps q)
     | Seq p2 q2 => and2 (eps p2) (eps q2)
     | Star y => True
   end"

fun epsR :: "R => R" where
"epsR x = (if eps x then Eps else Nil2)"

fun step :: "R => A => R" where
"step x y =
   case x of
     | other => Nil2
     | Atom a => (if eqA a y then Eps else Nil2)
     | Plus p q => plus (step p y) (step q y)
     | Seq p2 q2 =>
         plus (seq (step p2 y) q2) (seq (epsR p2) (step q2 y))
     | Star p3 => seq (step p3 y) x
   end"

fun recognise :: "R => A list => bool" where
"recognise x (Nil2) = eps x"
| "recognise x (Cons2 z xs) = recognise (step x z) xs"

(*hipster seq plus or2 eqA and2 eps epsR step recognise *)

theorem x0 :
  "!! (p :: R) (q :: R) (s :: A list) .
     (recognise (Plus p q) s) = (or2 (recognise p s) (recognise q s))"
  by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)

end