(*  Title:       Towards Decidability of Behavioral Equivalence for Unary PCF
    Author:      Dmitriy Traytel <traytel at inf.ethz.ch>, 2017
    Maintainer:  Dmitriy Traytel <traytel at inf.ethz.ch>
*)

section \<open>Towards Decidability of Behavioral Equivalence for Unary PCF\<close>

theory Unary_PCF
  imports
    "HOL-Library.FSet"
    "HOL-Library.Countable_Set_Type"
    "HOL-Library.Nat_Bijection"
    Hereditary_Multiset
    "List-Index.List_Index"
begin

subsection \<open>Preliminaries\<close>

lemma prod_UNIV: "UNIV = UNIV \<times> UNIV"
  by auto

subsection \<open>Types\<close>

datatype type = \<B> ("\<B>") | Fun type type (infixr "\<rightarrow>" 65)

definition mk_fun  (infixr "\<rightarrow>\<rightarrow>" 65) where
  "Ts \<rightarrow>\<rightarrow> T = fold (\<rightarrow>) (rev Ts) T"

primrec dest_fun where
  "dest_fun \<B> = []"
| "dest_fun (T \<rightarrow> U) = T # dest_fun U"

definition arity where
  "arity T = length (dest_fun T)"

lemma mk_fun_dest_fun[simp]: "dest_fun T \<rightarrow>\<rightarrow> \<B> = T"
  by (induct T) (auto simp: mk_fun_def)

lemma dest_fun_mk_fun[simp]: "dest_fun (Ts \<rightarrow>\<rightarrow> T) = Ts @ dest_fun T"
  by (induct Ts) (auto simp: mk_fun_def)

primrec \<delta> where
  "\<delta> \<B> = HMSet {#}"
| "\<delta> (T \<rightarrow> U) = HMSet (add_mset (\<delta> T) (hmsetmset (\<delta> U)))"

lemma \<delta>_mk_fun: "\<delta> (Ts \<rightarrow>\<rightarrow> T) = HMSet (hmsetmset (\<delta> T) + mset (map \<delta> Ts))"
  by (induct Ts) (auto simp: mk_fun_def)

lemma type_induct [case_names Fun]:
  assumes
   "(\<And>T. (\<And>T1 T2. T = T1 \<rightarrow> T2 \<Longrightarrow> P T1) \<Longrightarrow>
    (\<And>T1 T2. T = T1 \<rightarrow> T2 \<Longrightarrow> P T2) \<Longrightarrow> P T)"
  shows "P T"
proof (induct T)
  case \<B>
  show ?case by (rule assms) simp_all
next
  case Fun
  show ?case by (rule assms) (insert Fun, simp_all)
qed

subsection \<open>Terms\<close>

type_synonym name = string
type_synonym idx = nat
datatype expr =
    Var "name * type" ("\<langle>_\<rangle>") | Bound idx | B bool
  | Seq expr expr  (infixr "?" 75) | App expr expr (infixl "\<cdot>" 75)
  | Abs type expr ("\<Lambda>\<langle>_\<rangle> _" [100, 100] 800)

declare [[coercion_enabled]]
declare [[coercion B]]
declare [[coercion Bound]]

notation (output) B ("_")
notation (output) Bound ("_")

primrec "open" :: "idx \<Rightarrow> expr \<Rightarrow> expr \<Rightarrow> expr" where
  "open i t (j :: idx) = (if i = j then t else j)"
| "open i t \<langle>yU\<rangle> = \<langle>yU\<rangle>"
| "open i t (b :: bool) = b"
| "open i t (e1 ? e2) = open i t e1 ? open i t e2"
| "open i t (e1 \<cdot> e2) = open i t e1 \<cdot> open i t e2"
| "open i t (\<Lambda>\<langle>U\<rangle> e) = \<Lambda>\<langle>U\<rangle> (open (i + 1) t e)"

abbreviation "open0 \<equiv> open 0"
abbreviation "open_Var i xT \<equiv> open i \<langle>xT\<rangle>"
abbreviation "open0_Var xT \<equiv> open 0 \<langle>xT\<rangle>"

primrec "close_Var" :: "idx \<Rightarrow> name \<times> type \<Rightarrow> expr \<Rightarrow> expr" where
  "close_Var i xT (j :: idx) = j"
| "close_Var i xT \<langle>yU\<rangle> = (if xT = yU then i else \<langle>yU\<rangle>)"
| "close_Var i xT (b :: bool) = b"
| "close_Var i xT (e1 ? e2) = close_Var i xT e1 ? close_Var i xT e2"
| "close_Var i xT (e1 \<cdot> e2) = close_Var i xT e1 \<cdot> close_Var i xT e2"
| "close_Var i xT (\<Lambda>\<langle>U\<rangle> e) = \<Lambda>\<langle>U\<rangle> (close_Var (i + 1) xT e)"

abbreviation "close0_Var \<equiv> close_Var 0"

primrec "fv" :: "expr \<Rightarrow> (name \<times> type) fset" where
  "fv (j :: idx) = {||}"
| "fv \<langle>yU\<rangle> = {|yU|}"
| "fv (b :: bool) = {||}"
| "fv (e1 ? e2) = fv e1 |\<union>| fv e2"
| "fv (e1 \<cdot> e2) = fv e1 |\<union>| fv e2"
| "fv (\<Lambda>\<langle>U\<rangle> e) = fv e"

abbreviation "fresh x e \<equiv> x |\<notin>| fv e"

lemma ex_fresh: "\<exists>x. (x :: char list, T) |\<notin>| A"
proof (rule ccontr, unfold not_ex not_not)
  assume "\<forall>x. (x, T) |\<in>| A"
  then have "infinite {x. (x, T) |\<in>| A}" (is "infinite ?P")
    by (auto simp add: infinite_UNIV_listI)
  moreover
  have "?P \<subseteq> fst ` fset A"
    by (force simp: fmember.rep_eq)
  from finite_surj[OF _ this] have "finite ?P"
    by simp
  ultimately show False by blast
qed

inductive lc where
  lc_Var[simp]: "lc \<langle>xT\<rangle>"
| lc_B[simp]: "lc (b :: bool)"
| lc_Seq: "lc e1 \<Longrightarrow> lc e2 \<Longrightarrow> lc (e1 ? e2)"
| lc_App: "lc e1 \<Longrightarrow> lc e2 \<Longrightarrow> lc (e1 \<cdot> e2)"
| lc_Abs: "(\<forall>x. (x, T) |\<notin>| X \<longrightarrow> lc (open0_Var (x, T) e)) \<Longrightarrow> lc (\<Lambda>\<langle>T\<rangle> e)"

declare lc.intros[intro]

definition "body T t \<equiv> (\<exists>X. \<forall>x. (x, T) |\<notin>| X \<longrightarrow> lc (open0_Var (x, T) t))"

lemma lc_Abs_iff_body: "lc (\<Lambda>\<langle>T\<rangle> t) \<longleftrightarrow> body T t"
  unfolding body_def by (subst lc.simps) simp

lemma fv_open_Var: "fresh xT t \<Longrightarrow> fv (open_Var i xT t) |\<subseteq>| finsert xT (fv t)"
  by (induct t arbitrary: i) auto

lemma fv_close_Var[simp]: "fv (close_Var i xT t) = fv t |-| {|xT|}"
  by (induct t arbitrary: i) auto

lemma close_Var_open_Var[simp]: "fresh xT t \<Longrightarrow> close_Var i xT (open_Var i xT t) = t"
  by (induct t arbitrary: i) auto

lemma open_Var_inj: "fresh xT t \<Longrightarrow> fresh xT u \<Longrightarrow> open_Var i xT t = open_Var i xT u \<Longrightarrow> t = u"
  by (metis close_Var_open_Var)

context begin

private lemma open_Var_open_Var_close_Var: "i \<noteq> j \<Longrightarrow> xT \<noteq> yU \<Longrightarrow> fresh yU t \<Longrightarrow>
  open_Var i yU (open_Var j zV (close_Var j xT t)) = open_Var j zV (close_Var j xT (open_Var i yU t))"
  by (induct t arbitrary: i j) auto

lemma open_Var_close_Var[simp]: "lc t \<Longrightarrow> open_Var i xT (close_Var i xT t) = t"
proof (induction t arbitrary: i rule: lc.induct)
  case (lc_Abs T X e i)
  obtain x where x: "fresh (x, T) e" "(x, T) \<noteq> xT" "(x, T) |\<notin>| X"
    using ex_fresh[of _ "fv e |\<union>| finsert xT X"] by blast
  with lc_Abs.IH have "lc (open0_Var (x, T) e)"
    "open_Var (i + 1) xT (close_Var (i + 1) xT (open0_Var (x, T) e)) = open0_Var (x, T) e"
    by auto
  with x show ?case
    by (auto simp: open_Var_open_Var_close_Var
      dest: fset_mp[OF fv_open_Var, rotated]
      intro!: open_Var_inj[of "(x, T)" _ e 0])
qed auto

end

lemma close_Var_inj: "lc t \<Longrightarrow> lc u \<Longrightarrow> close_Var i xT t = close_Var i xT u \<Longrightarrow> t = u"
  by (metis open_Var_close_Var)

primrec Apps (infixl "\<bullet>" 75) where
  "f \<bullet> [] = f"
| "f \<bullet> (x # xs) = f \<cdot> x \<bullet> xs"

lemma Apps_snoc: "f \<bullet> (xs @ [x]) = f \<bullet> xs \<cdot> x"
  by (induct xs arbitrary: f) auto

lemma Apps_append: "f \<bullet> (xs @ ys) = f \<bullet>  xs \<bullet>  ys"
  by (induct xs arbitrary: f) auto

lemma Apps_inj[simp]: "f \<bullet> ts = g \<bullet> ts \<longleftrightarrow> f = g"
  by (induct ts arbitrary: f g) auto

lemma eq_Apps_conv[simp]:
  fixes i :: idx and b :: bool and f :: expr and ts :: "expr list"
  shows
    "(\<langle>m\<rangle> = f \<bullet> ts) = (\<langle>m\<rangle> = f \<and> ts = [])"
    "(f  \<bullet> ts = \<langle>m\<rangle>) = (\<langle>m\<rangle> = f \<and> ts = [])"
    "(i = f \<bullet> ts) = (i = f \<and> ts = [])"
    "(f \<bullet> ts = i) = (i = f \<and> ts = [])"
    "(b = f \<bullet> ts) = (b = f \<and> ts = [])"
    "(f \<bullet> ts = b) = (b = f \<and> ts = [])"
    "(e1 ? e2 = f \<bullet> ts) = (e1 ? e2 = f \<and> ts = [])"
    "(f \<bullet> ts = e1 ? e2) = (e1 ? e2 = f \<and> ts = [])"
    "(\<Lambda>\<langle>T\<rangle> t = f \<bullet> ts) = (\<Lambda>\<langle>T\<rangle> t = f \<and> ts = [])"
    "(f \<bullet> ts = \<Lambda>\<langle>T\<rangle> t) = (\<Lambda>\<langle>T\<rangle> t = f \<and> ts = [])"
  by (induct ts arbitrary: f) auto

lemma Apps_Var_eq[simp]: "\<langle>xT\<rangle> \<bullet> ss = \<langle>yU\<rangle> \<bullet> ts \<longleftrightarrow> xT = yU \<and> ss = ts"
proof (induct ss arbitrary: ts rule: rev_induct)
  case snoc
  then show ?case by (induct ts rule: rev_induct) (auto simp: Apps_snoc)
qed auto

lemma Apps_Abs_neq_Apps[simp, symmetric, simp]:
  "\<Lambda>\<langle>T\<rangle> r \<cdot> t \<noteq> \<langle>xT\<rangle> \<bullet> ss"
  "\<Lambda>\<langle>T\<rangle> r \<cdot> t \<noteq> (i :: idx) \<bullet> ss"
  "\<Lambda>\<langle>T\<rangle> r \<cdot> t \<noteq> (b :: bool) \<bullet> ss"
  "\<Lambda>\<langle>T\<rangle> r \<cdot> t \<noteq> (e1 ? e2) \<bullet> ss"
  by (induct ss rule: rev_induct) (auto simp: Apps_snoc)

lemma App_Abs_eq_Apps_Abs[simp]: "\<Lambda>\<langle>T\<rangle> r \<cdot> t = \<Lambda>\<langle>T'\<rangle> r' \<bullet> ss \<longleftrightarrow> T = T' \<and> r = r' \<and> ss = [t]"
  by (induct ss rule: rev_induct) (auto simp: Apps_snoc)

lemma Apps_Var_neq_Apps_Abs[simp, symmetric, simp]: "\<langle>xT\<rangle> \<bullet> ss \<noteq> \<Lambda>\<langle>T\<rangle> r \<bullet> ts"
proof (induct ss arbitrary: ts rule: rev_induct)
  case (snoc a ss)
  then show ?case by (induct ts rule: rev_induct) (auto simp: Apps_snoc)
qed simp

lemma Apps_Var_neq_Apps_beta[simp, THEN not_sym, simp]:
  "\<langle>xT\<rangle> \<bullet> ss \<noteq> \<Lambda>\<langle>T\<rangle> r \<cdot> s \<bullet> ts"
  by (metis Apps_Var_neq_Apps_Abs Apps_append Apps_snoc eq_Apps_conv(9))

lemma fold_eq_Bool_iff[simp]:
  "fold (\<rightarrow>) (rev Ts) T = \<B> \<longleftrightarrow> Ts = [] \<and> T = \<B>"
  "\<B> = fold (\<rightarrow>) (rev Ts) T \<longleftrightarrow> Ts = [] \<and> T = \<B>"
  by (induct Ts) auto

lemma fold_eq_Fun_iff[simp]:
  "fold (\<rightarrow>) (rev Ts) T = U \<rightarrow> V \<longleftrightarrow>
   (Ts = [] \<and> T = U \<rightarrow> V \<or> (\<exists>Us. Ts = U # Us \<and> fold (\<rightarrow>) (rev Us) T = V))"
  by (induct Ts) auto

subsection \<open>Substitution\<close>

primrec subst where
  "subst xT t \<langle>yU\<rangle> = (if xT = yU then t else \<langle>yU\<rangle>)"
| "subst xT t (i :: idx) = i"
| "subst xT t (b :: bool) = b"
| "subst xT t (e1 ? e2) = subst xT t e1 ? subst xT t e2"
| "subst xT t (e1 \<cdot> e2) = subst xT t e1 \<cdot> subst xT t e2"
| "subst xT t (\<Lambda>\<langle>T\<rangle> e) = \<Lambda>\<langle>T\<rangle> (subst xT t e)"

lemma fv_subst:
  "fv (subst xT t u) = fv u |-| {|xT|} |\<union>| (if xT |\<in>| fv u then fv t else {||})"
  by (induct u) auto

lemma subst_fresh: "fresh xT u \<Longrightarrow> subst xT t u = u"
  by (induct u) auto

context begin

private lemma open_open_id: "i \<noteq> j \<Longrightarrow> open i t (open j t' u) = open j t' u \<Longrightarrow> open i t u = u"
  by (induct u arbitrary: i j) (auto 6 0)

lemma lc_open_id: "lc u \<Longrightarrow> open k t u = u"
proof (induct u arbitrary: k rule: lc.induct)
  case (lc_Abs T X e)
  obtain x where x: "fresh (x, T) e" "(x, T) |\<notin>| X"
    using ex_fresh[of _ "fv e |\<union>| X"] by blast
  with lc_Abs show ?case
    by (auto intro: open_open_id dest: spec[of _ x] spec[of _ "Suc k"])
qed auto

lemma subst_open: "lc u \<Longrightarrow> subst xT u (open i t v) = open i (subst xT u t) (subst xT u v)"
  by (induction v arbitrary: i) (auto intro: lc_open_id[symmetric])

lemma subst_open_Var:
  "xT \<noteq> yU \<Longrightarrow> lc u \<Longrightarrow> subst xT u (open_Var i yU v) = open_Var i yU (subst xT u v)"
  by (auto simp: subst_open)

lemma subst_Apps[simp]:
  "subst xT u (f \<bullet> xs) = subst xT u f \<bullet> map (subst xT u) xs"
  by (induct xs arbitrary: f) auto

end

context begin

private lemma fresh_close_Var_id: "fresh xT t \<Longrightarrow> close_Var k xT t = t"
  by (induct t arbitrary: k) auto

lemma subst_close_Var:
  "xT \<noteq> yU \<Longrightarrow> fresh yU u \<Longrightarrow> subst xT u (close_Var i yU t) = close_Var i yU (subst xT u t)"
  by (induct t arbitrary: i) (auto simp: fresh_close_Var_id)

end

lemma subst_intro: "fresh xT t \<Longrightarrow> lc u \<Longrightarrow> open0 u t = subst xT u (open0_Var xT t)"
  by (auto simp: subst_fresh subst_open)

lemma lc_subst[simp]: "lc u \<Longrightarrow> lc t \<Longrightarrow> lc (subst xT t u)"
proof (induct u rule: lc.induct)
  case (lc_Abs T X e)
  then show ?case
    by (auto simp: subst_open_Var intro!: lc.lc_Abs[of _ "fv e |\<union>| X |\<union>| {|xT|}"])
qed auto

lemma body_subst[simp]: "body U u \<Longrightarrow> lc t \<Longrightarrow> body U (subst xT t u)"
proof (subst (asm) body_def, elim conjE exE)
  fix X
  assume [simp]: "lc t" "\<forall>x. (x, U) |\<notin>| X \<longrightarrow> lc (open0_Var (x, U) u)"
  show "body U (subst xT t u)"
  proof (unfold body_def, intro exI[of _ "finsert xT X"] conjI allI impI)
    fix x
    assume "(x, U) |\<notin>| finsert xT X"
    then show "lc (open0_Var (x, U) (subst xT t u))"
      by (auto simp: subst_open_Var[symmetric])
  qed
qed

lemma lc_open_Var: "lc u \<Longrightarrow> lc (open_Var i xT u)"
  by (simp add: lc_open_id)

lemma lc_open[simp]: "body U u \<Longrightarrow> lc t \<Longrightarrow> lc (open0 t u)"
proof (unfold body_def, elim conjE exE)
  fix X
  assume [simp]: "lc t" "\<forall>x. (x, U) |\<notin>| X \<longrightarrow> lc (open0_Var (x, U) u)"
  with ex_fresh[of _ "fv u |\<union>| X"] obtain x where [simp]: "fresh (x, U) u" "(x, U) |\<notin>| X" by blast
  show ?thesis by (subst subst_intro[of "(x, U)"]) auto
qed

subsection \<open>Typing\<close>

inductive welltyped :: "expr \<Rightarrow> type \<Rightarrow> bool" (infix ":::" 60) where
  welltyped_Var[intro!]: "\<langle>(x, T)\<rangle> ::: T"
| welltyped_B[intro!]: "(b :: bool) ::: \<B>"
| welltyped_Seq[intro!]: "e1 ::: \<B> \<Longrightarrow> e2 ::: \<B> \<Longrightarrow> e1 ? e2 ::: \<B>"
| welltyped_App[intro]: "e1 ::: T \<rightarrow> U \<Longrightarrow> e2 ::: T \<Longrightarrow> e1 \<cdot> e2 ::: U"
| welltyped_Abs[intro]: "(\<forall>x. (x, T) |\<notin>| X \<longrightarrow> open0_Var (x, T) e ::: U) \<Longrightarrow> \<Lambda>\<langle>T\<rangle> e ::: T \<rightarrow> U"

inductive_cases welltypedE[elim!]:
   "\<langle>x\<rangle> ::: T"
   "(i :: idx) ::: T"
   "(b :: bool) ::: T"
   "e1 ? e2 ::: T"
   "e1 \<cdot> e2 ::: T"
   "\<Lambda>\<langle>T\<rangle> e ::: U"

lemma welltyped_unique: "t ::: T \<Longrightarrow> t ::: U \<Longrightarrow> T = U"
proof (induction t T arbitrary: U rule: welltyped.induct)
  case (welltyped_Abs T X t U T')
  from welltyped_Abs.prems show ?case
  proof (elim welltypedE)
    fix Y U'
    obtain x where [simp]: "(x, T) |\<notin>| X" "(x, T) |\<notin>| Y"
      using ex_fresh[of _ "X |\<union>| Y"] by blast
    assume [simp]: "T' = T \<rightarrow> U'" "\<forall>x. (x, T) |\<notin>| Y \<longrightarrow> open0_Var (x, T) t ::: U'"
    show "T \<rightarrow> U = T'"
      by (auto intro: conjunct2[OF welltyped_Abs.IH[rule_format], rule_format, of x])
  qed
qed blast+

lemma welltyped_lc[simp]: "t ::: T \<Longrightarrow> lc t"
  by (induction t T rule: welltyped.induct) auto

lemma welltyped_subst[intro]:
  "u ::: U \<Longrightarrow> t ::: snd xT \<Longrightarrow> subst xT t u ::: U"
proof (induction u U rule: welltyped.induct)
  case (welltyped_Abs T' X u U)
  then show ?case unfolding subst.simps
    by (intro welltyped.welltyped_Abs[of _ "finsert xT X"]) (auto simp: subst_open_Var[symmetric])
qed auto

lemma rename_welltyped: "u ::: U \<Longrightarrow> subst (x, T) \<langle>(y, T)\<rangle> u ::: U"
  by (rule welltyped_subst) auto

lemma welltyped_Abs_fresh:
  assumes "fresh (x, T) u" "open0_Var (x, T) u ::: U"
  shows "\<Lambda>\<langle>T\<rangle> u ::: T \<rightarrow> U"
proof (intro welltyped_Abs[of _ "fv u"] allI impI)
  fix y
  assume "fresh (y, T) u"
  with assms(2) have "subst (x, T) \<langle>(y, T)\<rangle> (open0_Var (x, T) u) ::: U" (is "?t ::: _")
    by (auto intro: rename_welltyped)
  also have "?t = open0_Var (y, T) u"
    by (subst subst_intro[symmetric]) (auto simp: assms(1))
  finally show "open0_Var (y, T) u ::: U" .
qed

lemma Apps_alt: "f \<bullet> ts ::: T \<longleftrightarrow>
  (\<exists>Ts. f ::: fold (\<rightarrow>) (rev Ts) T \<and> list_all2 (:::) ts Ts)"
proof (induct ts arbitrary: f)
  case (Cons t ts)
  from Cons(1)[of "f \<cdot> t"] show ?case
    by (force simp: list_all2_Cons1)
qed simp

subsection \<open>Definition 10 and Lemma 11 from Schmidt-Schauß's paper\<close>

abbreviation "closed t \<equiv> fv t = {||}"

primrec constant0 where
  "constant0 \<B> = Var (''bool'', \<B>)"
| "constant0 (T \<rightarrow> U) = \<Lambda>\<langle>T\<rangle> (constant0 U)"

definition "constant T = \<Lambda>\<langle>\<B>\<rangle> (close0_Var (''bool'', \<B>) (constant0 T))"

lemma fv_constant0[simp]: "fv (constant0 T) = {|(''bool'', \<B>)|}"
  by (induct T) auto

lemma closed_constant[simp]: "closed (constant T)"
  unfolding constant_def by auto

lemma welltyped_constant0[simp]: "constant0 T ::: T"
  by (induct T) (auto simp: lc_open_id)

lemma lc_constant0[simp]: "lc (constant0 T)"
  using welltyped_constant0 welltyped_lc by blast

lemma welltyped_constant[simp]: "constant T ::: \<B> \<rightarrow> T"
  unfolding constant_def by (auto intro: welltyped_Abs_fresh[of "''bool''"])

definition nth_drop where
  "nth_drop i xs \<equiv> take i xs @ drop (Suc i) xs"

definition nth_arg (infixl "!-" 100) where
  "nth_arg T i \<equiv> nth (dest_fun T) i"

abbreviation ar where
  "ar T \<equiv> length (dest_fun T)"

lemma size_nth_arg[simp]: "i < ar T \<Longrightarrow> size (T !- i) < size T"
  by (induct T arbitrary: i) (force simp: nth_Cons' nth_arg_def gr0_conv_Suc)+

fun \<pi> :: "type \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> type" where
  "\<pi> T i 0 = (if i < ar T then nth_drop i (dest_fun T) \<rightarrow>\<rightarrow> \<B> else \<B>)"
| "\<pi> T i (Suc j) = (if i < ar T \<and> j < ar (T!-i)
    then \<pi> (T!-i) j 0 \<rightarrow>
      map (\<pi> (T!-i) j o Suc) [0 ..< ar (T!-i!-j)] \<rightarrow>\<rightarrow> \<pi> T i 0 else \<B>)"

theorem \<pi>_induct[rotated -2, consumes 2, case_names 0 Suc]:
  assumes "\<And>T i. i < ar T \<Longrightarrow> P T i 0"
    and "\<And>T i j. i < ar T \<Longrightarrow> j < ar (T !- i) \<Longrightarrow> P (T !- i) j 0 \<Longrightarrow>
       (\<forall>x < ar (T !- i !- j). P (T !- i) j (x + 1)) \<Longrightarrow> P T i (j + 1)"
  shows "i < ar T \<Longrightarrow> j \<le> ar (T !- i) \<Longrightarrow> P T i j"
  by (induct T i j rule: \<pi>.induct) (auto intro: assms[simplified])

definition \<epsilon> :: "type \<Rightarrow> nat \<Rightarrow> type" where
  "\<epsilon> T i = \<pi> T i 0 \<rightarrow> map (\<pi> T i o Suc) [0 ..< ar (T!-i)] \<rightarrow>\<rightarrow> T"

definition Abss ("\<Lambda>[_] _" [100, 100] 800) where
  "\<Lambda>[xTs] b = fold (\<lambda>xT t. \<Lambda>\<langle>snd xT\<rangle> close0_Var xT t) (rev xTs) b"

definition Seqs (infixr "??" 75) where
  "ts ?? t = fold (\<lambda>u t. u ? t) (rev ts) t"

definition "variant k base = base @ replicate k CHR ''*''"

lemma variant_inj: "variant i base = variant j base \<Longrightarrow> i = j"
  unfolding variant_def by auto

lemma variant_inj2:
  "CHR ''*'' \<notin> set b1 \<Longrightarrow> CHR ''*'' \<notin> set b2 \<Longrightarrow> variant i b1 = variant j b2 \<Longrightarrow> b1 = b2"
  unfolding variant_def
  by (auto simp: append_eq_append_conv2)
    (metis Nil_is_append_conv hd_append2 hd_in_set hd_rev last_ConsR
     last_snoc replicate_append_same rev_replicate)+

fun E :: "type \<Rightarrow> nat \<Rightarrow> expr" and P :: "type \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> expr" where
  "E T i = (if i < ar T then (let
       Ti = T!-i;
       x = \<lambda>k. (variant k ''x'', T!-k);
       xs = map x [0 ..< ar T];
       xx_var = \<langle>nth xs i\<rangle>;
       x_vars = map (\<lambda>x. \<langle>x\<rangle>) (nth_drop i xs);
       yy = (''z'', \<pi> T i 0);
       yy_var = \<langle>yy\<rangle>;
       y = \<lambda>j. (variant j ''y'', \<pi> T i (j + 1));
       ys = map y [0 ..< ar Ti];
       e = \<lambda>j. \<langle>y j\<rangle> \<bullet> (P Ti j 0 \<cdot> xx_var # map (\<lambda>k. P Ti j (k + 1) \<cdot> xx_var) [0 ..< ar (Ti!-j)]);
       guards = map (\<lambda>i. xx_var \<bullet>
           map (\<lambda>j. constant (Ti!-j) \<cdot> (if i = j then e i \<bullet> x_vars else True)) [0 ..< ar Ti])
         [0 ..< ar Ti]
     in \<Lambda>[(yy # ys @ xs)] (guards ?? (yy_var \<bullet> x_vars))) else constant (\<epsilon> T i) \<cdot> False)"
| "P T i 0 =
     (if i < ar T then (let
       f = (''f'', T);
       f_var = \<langle>f\<rangle>;
       x = \<lambda>k. (variant k ''x'', T!-k);
       xs = nth_drop i (map x [0 ..< ar T]);
       x_vars = insert_nth i (constant (T!-i) \<cdot> True) (map (\<lambda>x. \<langle>x\<rangle>) xs)
     in \<Lambda>[(f # xs)] (f_var \<bullet> x_vars)) else constant (T \<rightarrow> \<pi> T i 0) \<cdot> False)"
| "P T i (Suc j) = (if i < ar T \<and> j < ar (T!-i) then (let
       Ti = T!-i;
       Tij = Ti!-j;
       f = (''f'', T);
       f_var = \<langle>f\<rangle>;
       x = \<lambda>k. (variant k ''x'', T!-k);
       xs = nth_drop i (map x [0 ..< ar T]);
       yy = (''z'', \<pi> Ti j 0);
       yy_var = \<langle>yy\<rangle>;
       y = \<lambda>k. (variant k ''y'', \<pi> Ti j (k + 1));
       ys = map y [0 ..< ar Tij];
       y_vars = yy_var # map (\<lambda>x. \<langle>x\<rangle>) ys;
       x_vars = insert_nth i (E Ti j \<bullet> y_vars) (map (\<lambda>x. \<langle>x\<rangle>) xs)
     in \<Lambda>[(f # yy # ys @ xs)] (f_var \<bullet> x_vars)) else constant (T \<rightarrow> \<pi> T i (j + 1)) \<cdot> False)"

lemma Abss_Nil[simp]: "\<Lambda>[[]] b = b"
  unfolding Abss_def by simp

lemma Abss_Cons[simp]: "\<Lambda>[(x#xs)] b = \<Lambda>\<langle>snd x\<rangle> (close0_Var x (\<Lambda>[xs] b))"
  unfolding Abss_def by simp

lemma welltyped_Abss: "b ::: U \<Longrightarrow> T = map snd xTs \<rightarrow>\<rightarrow> U \<Longrightarrow> \<Lambda>[xTs] b ::: T"
  by (hypsubst_thin, induct xTs) (auto simp: mk_fun_def intro!: welltyped_Abs_fresh)

lemma welltyped_Apps: "list_all2 (:::) ts Ts \<Longrightarrow> f ::: Ts \<rightarrow>\<rightarrow> U \<Longrightarrow> f \<bullet> ts ::: U"
  by (induct ts Ts arbitrary: f rule: list.rel_induct) (auto simp: mk_fun_def)

lemma welltyped_open_Var_close_Var[intro!]:
  "t ::: T \<Longrightarrow> open0_Var xT (close0_Var xT t) ::: T"
  by auto

lemma welltyped_Var_iff[simp]:
  "\<langle>(x, T)\<rangle> ::: U \<longleftrightarrow> T = U"
  by auto

lemma welltyped_bool_iff[simp]: "(b :: bool) ::: T \<longleftrightarrow> T = \<B>"
  by auto

lemma welltyped_constant0_iff[simp]: "constant0 T ::: U \<longleftrightarrow> (U = T)"
  by (induct T arbitrary: U) (auto simp: ex_fresh lc_open_id)

lemma welltyped_constant_iff[simp]: "constant T ::: U \<longleftrightarrow> (U = \<B> \<rightarrow> T)"
  unfolding constant_def
proof (intro iffI, elim welltypedE, hypsubst_thin, unfold type.inject simp_thms)
  fix X U
  assume "\<forall>x. (x, \<B>) |\<notin>| X \<longrightarrow> open0_Var (x, \<B>) (close0_Var (''bool'', \<B>) (constant0 T)) ::: U"
  moreover obtain x where "(x, \<B>) |\<notin>| X" using ex_fresh[of \<B> X] by blast
  ultimately have "open0_Var (x, \<B>) (close0_Var (''bool'', \<B>) (constant0 T)) ::: U" by simp
  then have "open0_Var (''bool'', \<B>) (close0_Var (''bool'', \<B>) (constant0 T)) ::: U"
    using rename_welltyped[of \<open>open0_Var (x, \<B>) (close0_Var (''bool'', \<B>) (constant0 T))\<close>
       U x \<B> "''bool''"]
    by (auto simp: subst_open subst_fresh)
  then show "U = T" by auto
qed (auto intro!: welltyped_Abs_fresh)

lemma welltyped_Seq_iff[simp]: "e1 ? e2 ::: T \<longleftrightarrow> (T = \<B> \<and> e1 ::: \<B> \<and> e2 ::: \<B>)"
  by auto

lemma welltyped_Seqs_iff[simp]: "es ?? e ::: T \<longleftrightarrow>
  ((es \<noteq> [] \<longrightarrow> T = \<B>) \<and> (\<forall>e \<in> set es. e ::: \<B>) \<and> e ::: T)"
  by (induct es arbitrary: e) (auto simp: Seqs_def)

lemma welltyped_App_iff[simp]: "f \<cdot> t ::: U \<longleftrightarrow> (\<exists>T. f ::: T \<rightarrow> U \<and> t ::: T)"
  by auto

lemma welltyped_Apps_iff[simp]: "f \<bullet> ts ::: U \<longleftrightarrow> (\<exists>Ts. f ::: Ts \<rightarrow>\<rightarrow> U \<and> list_all2 (:::) ts Ts)"
  by (induct ts arbitrary: f) (auto 0 3 simp: mk_fun_def list_all2_Cons1 intro: exI[of _ "_ # _"])

lemma eq_mk_fun_iff[simp]: "T = Ts \<rightarrow>\<rightarrow> \<B> \<longleftrightarrow> Ts = dest_fun T"
  by auto

lemma map_nth_eq_drop_take[simp]: "j \<le> length xs \<Longrightarrow> map (nth xs) [i ..< j] = drop i (take j xs)"
  by (induct j) (auto simp: take_Suc_conv_app_nth)

lemma dest_fun_\<pi>_0: "i < ar T \<Longrightarrow> dest_fun (\<pi> T i 0) = nth_drop i (dest_fun T)"
  by auto

lemma welltyped_E: "E T i ::: \<epsilon> T i" and welltyped_P: "P T i j ::: T \<rightarrow> \<pi> T i j"
proof (induct T i and T i j rule: E_P.induct)
  case (1 T i)
  note P.simps[simp del] \<pi>.simps[simp del] \<epsilon>_def[simp] nth_drop_def[simp] nth_arg_def[simp]
  from 1(1)[OF _ refl refl refl refl refl refl refl refl refl]
       1(2)[OF _ refl refl refl refl refl refl refl refl refl]
  show ?case
    by (auto 0 4 simp: Let_def o_def take_map[symmetric] drop_map[symmetric]
      list_all2_conv_all_nth nth_append min_def dest_fun_\<pi>_0 \<pi>.simps[of T i]
      intro!: welltyped_Abs_fresh welltyped_Abss[of _ \<B>])
next
  case (2 T i)
  show ?case
    by (auto simp: Let_def take_map drop_map o_def list_all2_conv_all_nth nth_append nth_Cons'
       nth_drop_def nth_arg_def
      intro!: welltyped_constant welltyped_Abs_fresh welltyped_Abss[of _ \<B>])
next
  case (3 T i j)
  note E.simps[simp del] \<pi>.simps[simp del] Abss_Cons[simp del] \<epsilon>_def[simp]
    nth_drop_def[simp] nth_arg_def[simp]
  from 3(1)[OF _ refl refl refl refl refl refl refl refl refl refl refl]
  show ?case
    by (auto 0 3 simp: Let_def o_def take_map[symmetric] drop_map[symmetric]
      list_all2_conv_all_nth nth_append nth_Cons' min_def \<pi>.simps[of T i]
      intro!: welltyped_Abs_fresh welltyped_Abss[of _ \<B>])
qed

lemma \<delta>_gt_0[simp]: "T \<noteq> \<B> \<Longrightarrow> HMSet {#} < \<delta> T"
  by (cases T) auto

lemma mset_nth_drop_less: "i < length xs \<Longrightarrow> mset (nth_drop i xs) < mset xs"
  by (induct xs arbitrary: i) (auto simp: take_Cons' nth_drop_def gr0_conv_Suc)

lemma map_nth_drop: "i < length xs \<Longrightarrow> map f (nth_drop i xs) = nth_drop i (map f xs)"
  by (induct xs arbitrary: i) (auto simp: take_Cons' nth_drop_def gr0_conv_Suc)

lemma empty_less_mset: "{#} < mset xs \<longleftrightarrow> xs \<noteq> []"
  by auto

lemma dest_fun_alt: "dest_fun T = map (\<lambda>i. T !- i) [0..<ar T]"
  unfolding list_eq_iff_nth_eq nth_arg_def by auto

context notes \<pi>.simps[simp del] notes One_nat_def[simp del] begin

lemma \<delta>_\<pi>:
  assumes "i < ar T" "j \<le> ar (T !- i)"
  shows "\<delta> (\<pi> T i j) < \<delta> T"
using assms proof (induct T i j rule: \<pi>_induct)
  fix T i
  assume "i < ar T"
  then show "\<delta> (\<pi> T i 0) < \<delta> T"
    by (subst (2) mk_fun_dest_fun[symmetric, of T], unfold \<delta>_mk_fun)
      (auto simp: \<delta>_mk_fun mset_map[symmetric] take_map[symmetric] drop_map[symmetric] \<pi>.simps
        mset_nth_drop_less map_nth_drop simp del: mset_map)
next
  fix T i j
  let ?Ti = "T !- i"
  assume [rule_format, simp]: "i < ar T" "j < ar ?Ti" "\<delta> (\<pi> ?Ti j 0) < \<delta> ?Ti"
    "\<forall>k < ar (?Ti !- j). \<delta> (\<pi> ?Ti j (k + 1)) < \<delta> ?Ti"
  define X and Y and M where
    [simp]: "X = {#\<delta> ?Ti#}" and
    [simp]: "Y = {#\<delta> (\<pi> ?Ti j 0)#} + {#\<delta> (\<pi> ?Ti j (k + 1)). k \<in># mset [0 ..< ar (?Ti !- j)]#}" and
    [simp]: "M \<equiv> {# \<delta> z. z \<in># mset (nth_drop i (dest_fun T))#}"
  have "\<delta> (\<pi> T i (j + 1)) = HMSet (Y + M)"
    by (auto simp: One_nat_def \<pi>.simps \<delta>_mk_fun)
  also have "Y + M < X + M"
    unfolding less_multiset\<^sub>D\<^sub>M by (rule exI[of _ "X"], rule exI[of _ "Y"]) auto
  also have "HMSet (X + M) = \<delta> T"
    unfolding M_def
    by (subst (2) mk_fun_dest_fun[symmetric, of T], subst (2) id_take_nth_drop[of i "dest_fun T"])
      (auto simp: \<delta>_mk_fun nth_arg_def nth_drop_def)
  finally show "\<delta> (\<pi> T i (j + 1)) < \<delta> T" by simp
qed

end

end


theory Floats
  imports Main IEEE_Floating_Point.FP64 FP32 Integers
begin

(* use IEEE_Floating_Point for float types *)

lemma "is_single (f::float32 itself)"
  unfolding is_single_def wordlength_def by simp
lemma "is_double (f::float64 itself)"
  unfolding is_double_def wordlength_def by simp

abbreviation "Float32_repr i \<equiv> float_of_fp32 (word_of_int i)"
abbreviation "Float64_repr i \<equiv> float_of_fp64 (word_of_int i)"

instantiation float :: (len, len) equal
begin

lift_definition equal_float :: "('a, 'b) IEEE.float \<Rightarrow> ('a, 'b) IEEE.float \<Rightarrow> bool" is
  "(=)"
  done

instance
  apply standard
  apply transfer
  by simp
end

locale FloatOps =
  fixes ft :: "('a,'b) float itself"
begin
abbreviation add :: "('a,'b) float \<Rightarrow> ('a,'b) float \<Rightarrow> ('a,'b) float" where
  "add \<equiv> (+)"
abbreviation sub :: "('a,'b) float \<Rightarrow> ('a,'b) float \<Rightarrow> ('a,'b) float" where
  "sub \<equiv> (-)"
abbreviation mul :: "('a,'b) float \<Rightarrow> ('a,'b) float \<Rightarrow> ('a,'b) float" where
  "mul \<equiv> (*)"
abbreviation div' :: "('a,'b) float \<Rightarrow> ('a,'b) float \<Rightarrow> ('a,'b) float" where
  "div' \<equiv> (/)"

abbreviation cmp :: "comparison \<Rightarrow> ('a,'b) float \<Rightarrow> ('a,'b) float \<Rightarrow> bool" where
  "cmp \<equiv> do_cmp"
end

interpretation Float : FloatOps "TYPE(float64)" .
interpretation Float32 : FloatOps "TYPE(float32)" .

end


(*  Title:      HOL/Hoare/SchorrWaite.thy
    Author:     Farhad Mehta
    Copyright   2003 TUM

Proof of the Schorr-Waite graph marking algorithm.
*)

theory SchorrWaite imports HeapSyntax begin

section \<open>Machinery for the Schorr-Waite proof\<close>

definition
  \<comment> "Relations induced by a mapping"
  rel :: "('a \<Rightarrow> 'a ref) \<Rightarrow> ('a \<times> 'a) set"
  where "rel m = {(x,y). m x = Ref y}"

definition
  relS :: "('a \<Rightarrow> 'a ref) set \<Rightarrow> ('a \<times> 'a) set"
  where "relS M = (\<Union>m \<in> M. rel m)"

definition
  addrs :: "'a ref set \<Rightarrow> 'a set"
  where "addrs P = {a. Ref a \<in> P}"

definition
  reachable :: "('a \<times> 'a) set \<Rightarrow> 'a ref set \<Rightarrow> 'a set"
  where "reachable r P = (r\<^sup>* `` addrs P)"

lemmas rel_defs = relS_def rel_def

text \<open>Rewrite rules for relations induced by a mapping\<close>

lemma self_reachable: "b \<in> B \<Longrightarrow> b \<in> R\<^sup>* `` B"
apply blast
done

lemma oneStep_reachable: "b \<in> R``B \<Longrightarrow> b \<in> R\<^sup>* `` B"
apply blast
done

lemma still_reachable: "\<lbrakk>B\<subseteq>Ra\<^sup>*``A; \<forall> (x,y) \<in> Rb-Ra. y\<in> (Ra\<^sup>*``A)\<rbrakk> \<Longrightarrow> Rb\<^sup>* `` B \<subseteq> Ra\<^sup>* `` A "
apply (clarsimp simp only:Image_iff)
apply (erule rtrancl_induct)
 apply blast
apply (subgoal_tac "(y, z) \<in> Ra\<union>(Rb-Ra)")
 apply (erule UnE)
 apply (auto intro:rtrancl_into_rtrancl)
apply blast
done

lemma still_reachable_eq: "\<lbrakk> A\<subseteq>Rb\<^sup>*``B; B\<subseteq>Ra\<^sup>*``A; \<forall> (x,y) \<in> Ra-Rb. y \<in>(Rb\<^sup>*``B); \<forall> (x,y) \<in> Rb-Ra. y\<in> (Ra\<^sup>*``A)\<rbrakk> \<Longrightarrow> Ra\<^sup>*``A =  Rb\<^sup>*``B "
apply (rule equalityI)
 apply (erule still_reachable ,assumption)+
done

lemma reachable_null: "reachable mS {Null} = {}"
apply (simp add: reachable_def addrs_def)
done

lemma reachable_empty: "reachable mS {} = {}"
apply (simp add: reachable_def addrs_def)
done

lemma reachable_union: "(reachable mS aS \<union> reachable mS bS) = reachable mS (aS \<union> bS)"
apply (simp add: reachable_def rel_defs addrs_def)
apply blast
done

lemma reachable_union_sym: "reachable r (insert a aS) = (r\<^sup>* `` addrs {a}) \<union> reachable r aS"
apply (simp add: reachable_def rel_defs addrs_def)
apply blast
done

lemma rel_upd1: "(a,b) \<notin> rel (r(q:=t)) \<Longrightarrow> (a,b) \<in> rel r \<Longrightarrow> a=q"
apply (rule classical)
apply (simp add:rel_defs fun_upd_apply)
done

lemma rel_upd2: "(a,b)  \<notin> rel r \<Longrightarrow> (a,b) \<in> rel (r(q:=t)) \<Longrightarrow> a=q"
apply (rule classical)
apply (simp add:rel_defs fun_upd_apply)
done

definition
  \<comment> "Restriction of a relation"
  restr ::"('a \<times> 'a) set \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> ('a \<times> 'a) set"       ("(_/ | _)" [50, 51] 50)
  where "restr r m = {(x,y). (x,y) \<in> r \<and> \<not> m x}"

text \<open>Rewrite rules for the restriction of a relation\<close>

lemma restr_identity[simp]:
 " (\<forall>x. \<not> m x) \<Longrightarrow> (R |m) = R"
by (auto simp add:restr_def)

lemma restr_rtrancl[simp]: " \<lbrakk>m l\<rbrakk> \<Longrightarrow> (R | m)\<^sup>* `` {l} = {l}"
by (auto simp add:restr_def elim:converse_rtranclE)

lemma restr_upd: "((rel (r (q := t)))|(m(q := True))) = ((rel (r))|(m(q := True))) "
apply (auto simp:restr_def rel_def fun_upd_apply)
apply (rename_tac a b)
apply (case_tac "a=q")
 apply auto
done

lemma restr_un: "((r \<union> s)|m) = (r|m) \<union> (s|m)"
  by (auto simp add:restr_def)

lemma rel_upd3: "(a, b) \<notin> (r|(m(q := t))) \<Longrightarrow> (a,b) \<in> (r|m) \<Longrightarrow> a = q "
apply (rule classical)
apply (simp add:restr_def fun_upd_apply)
done

definition
  \<comment> "A short form for the stack mapping function for List"
  S :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'a ref) \<Rightarrow> ('a \<Rightarrow> 'a ref) \<Rightarrow> ('a \<Rightarrow> 'a ref)"
  where "S c l r = (\<lambda>x. if c x then r x else l x)"

text \<open>Rewrite rules for Lists using S as their mapping\<close>

lemma [rule_format,simp]:
 "\<forall>p. a \<notin> set stack \<longrightarrow> List (S c l r) p stack = List (S (c(a:=x)) (l(a:=y)) (r(a:=z))) p stack"
apply(induct_tac stack)
 apply(simp add:fun_upd_apply S_def)+
done

lemma [rule_format,simp]:
 "\<forall>p. a \<notin> set stack \<longrightarrow> List (S c l (r(a:=z))) p stack = List (S c l r) p stack"
apply(induct_tac stack)
 apply(simp add:fun_upd_apply S_def)+
done

lemma [rule_format,simp]:
 "\<forall>p. a \<notin> set stack \<longrightarrow> List (S c (l(a:=z)) r) p stack = List (S c l r) p stack"
apply(induct_tac stack)
 apply(simp add:fun_upd_apply S_def)+
done

lemma [rule_format,simp]:
 "\<forall>p. a \<notin> set stack \<longrightarrow> List (S (c(a:=z)) l r) p stack = List (S c l r) p stack"
apply(induct_tac stack)
 apply(simp add:fun_upd_apply S_def)+
done

primrec
  \<comment>"Recursive definition of what is means for a the graph/stack structure to be reconstructible"
  stkOk :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'a ref) \<Rightarrow> ('a \<Rightarrow> 'a ref) \<Rightarrow> ('a \<Rightarrow> 'a ref) \<Rightarrow> ('a \<Rightarrow> 'a ref) \<Rightarrow> 'a ref \<Rightarrow>'a list \<Rightarrow>  bool"
where
  stkOk_nil:  "stkOk c l r iL iR t [] = True"
| stkOk_cons:
    "stkOk c l r iL iR t (p#stk) = (stkOk c l r iL iR (Ref p) (stk) \<and>
      iL p = (if c p then l p else t) \<and>
      iR p = (if c p then t else r p))"

text \<open>Rewrite rules for stkOk\<close>

lemma [simp]: "\<And>t. \<lbrakk> x \<notin> set xs; Ref x\<noteq>t \<rbrakk> \<Longrightarrow>
  stkOk (c(x := f)) l r iL iR t xs = stkOk c l r iL iR t xs"
apply (induct xs)
 apply (auto simp:eq_sym_conv)
done

lemma [simp]: "\<And>t. \<lbrakk> x \<notin> set xs; Ref x\<noteq>t \<rbrakk> \<Longrightarrow>
 stkOk c (l(x := g)) r iL iR t xs = stkOk c l r iL iR t xs"
apply (induct xs)
 apply (auto simp:eq_sym_conv)
done

lemma [simp]: "\<And>t. \<lbrakk> x \<notin> set xs; Ref x\<noteq>t \<rbrakk> \<Longrightarrow>
 stkOk c l (r(x := g)) iL iR t xs = stkOk c l r iL iR t xs"
apply (induct xs)
 apply (auto simp:eq_sym_conv)
done

lemma stkOk_r_rewrite [simp]: "\<And>x. x \<notin> set xs \<Longrightarrow>
  stkOk c l (r(x := g)) iL iR (Ref x) xs = stkOk c l r iL iR (Ref x) xs"
apply (induct xs)
 apply (auto simp:eq_sym_conv)
done

lemma [simp]: "\<And>x. x \<notin> set xs \<Longrightarrow>
 stkOk c (l(x := g)) r iL iR (Ref x) xs = stkOk c l r iL iR (Ref x) xs"
apply (induct xs)
 apply (auto simp:eq_sym_conv)
done

lemma [simp]: "\<And>x. x \<notin> set xs \<Longrightarrow>
 stkOk (c(x := g)) l r iL iR (Ref x) xs = stkOk c l r iL iR (Ref x) xs"
apply (induct xs)
 apply (auto simp:eq_sym_conv)
done

section\<open>The Schorr-Waite algorithm\<close>

theorem SchorrWaiteAlgorithm:
"VARS c m l r t p q root
 {R = reachable (relS {l, r}) {root} \<and> (\<forall>x. \<not> m x) \<and> iR = r \<and> iL = l}
 t := root; p := Null;
 WHILE p \<noteq> Null \<or> t \<noteq> Null \<and> \<not> t^.m
 INV {\<exists>stack.
          List (S c l r) p stack \<and>                                         (*i1*)
          (\<forall>x \<in> set stack. m x) \<and>                                        (*i2*)
          R = reachable (relS{l, r}) {t,p} \<and>                           (*i3*)
          (\<forall>x. x \<in> R \<and> \<not>m x \<longrightarrow>                                        (*i4*)
                 x \<in> reachable (relS{l,r}|m) ({t}\<union>set(map r stack))) \<and>
          (\<forall>x. m x \<longrightarrow> x \<in> R) \<and>                                         (*i5*)
          (\<forall>x. x \<notin> set stack \<longrightarrow> r x = iR x \<and> l x = iL x) \<and>       (*i6*)
          (stkOk c l r iL iR t stack)                                    (*i7*) }
 DO IF t = Null \<or> t^.m
      THEN IF p^.c
               THEN q := t; t := p; p := p^.r; t^.r := q               (*pop*)
               ELSE q := t; t := p^.r; p^.r := p^.l;                      (*swing*)
                        p^.l := q; p^.c := True          FI
      ELSE q := p; p := t; t := t^.l; p^.l := q;                         (*push*)
               p^.m := True; p^.c := False            FI       OD
 {(\<forall>x. (x \<in> R) = m x) \<and> (r = iR \<and> l = iL) }"
  (is "VARS c m l r t p q root {?Pre c m l r root} (?c1; ?c2; ?c3) {?Post c m l r}")
proof (vcg)
  let "While {(c, m, l, r, t, p, q, root). ?whileB m t p}
    {(c, m, l, r, t, p, q, root). ?inv c m l r t p} ?body" = ?c3
  {

    fix c m l r t p q root
    assume "?Pre c m l r root"
    thus "?inv c m l r root Null"  by (auto simp add: reachable_def addrs_def)
  next

    fix c m l r t p q
    let "\<exists>stack. ?Inv stack"  =  "?inv c m l r t p"
    assume a: "?inv c m l r t p \<and> \<not>(p \<noteq> Null \<or> t \<noteq> Null \<and> \<not> t^.m)"
    then obtain stack where inv: "?Inv stack" by blast
    from a have pNull: "p = Null" and tDisj: "t=Null \<or> (t\<noteq>Null \<and> t^.m )" by auto
    let "?I1 \<and> _ \<and> _ \<and> ?I4 \<and> ?I5 \<and> ?I6 \<and> _"  =  "?Inv stack"
    from inv have i1: "?I1" and i4: "?I4" and i5: "?I5" and i6: "?I6" by simp+
    from pNull i1 have stackEmpty: "stack = []" by simp
    from tDisj i4 have RisMarked[rule_format]: "\<forall>x.  x \<in> R \<longrightarrow> m x"  by(auto simp: reachable_def addrs_def stackEmpty)
    from i5 i6 show "(\<forall>x.(x \<in> R) = m x) \<and> r = iR \<and> l = iL"  by(auto simp: stackEmpty fun_eq_iff intro:RisMarked)

  next
      fix c m l r t p q root
      let "\<exists>stack. ?Inv stack"  =  "?inv c m l r t p"
      let "\<exists>stack. ?popInv stack"  =  "?inv c m l (r(p \<rightarrow> t)) p (p^.r)"
      let "\<exists>stack. ?swInv stack"  =
        "?inv (c(p \<rightarrow> True)) m (l(p \<rightarrow> t)) (r(p \<rightarrow> p^.l)) (p^.r) p"
      let "\<exists>stack. ?puInv stack"  =
        "?inv (c(t \<rightarrow> False)) (m(t \<rightarrow> True)) (l(t \<rightarrow> p)) r (t^.l) t"
      let "?ifB1"  =  "(t = Null \<or> t^.m)"
      let "?ifB2"  =  "p^.c"

      assume "(\<exists>stack.?Inv stack) \<and> (p \<noteq> Null \<or> t \<noteq> Null \<and> \<not> t^.m)" (is "_ \<and> ?whileB")
      then obtain stack where inv: "?Inv stack" and whileB: "?whileB" by blast
      let "?I1 \<and> ?I2 \<and> ?I3 \<and> ?I4 \<and> ?I5 \<and> ?I6 \<and> ?I7" = "?Inv stack"
      from inv have i1: "?I1" and i2: "?I2" and i3: "?I3" and i4: "?I4"
                  and i5: "?I5" and i6: "?I6" and i7: "?I7" by simp+
      have stackDist: "distinct (stack)" using i1 by (rule List_distinct)

      show "(?ifB1 \<longrightarrow> (?ifB2 \<longrightarrow> (\<exists>stack.?popInv stack)) \<and>
                            (\<not>?ifB2 \<longrightarrow> (\<exists>stack.?swInv stack)) ) \<and>
              (\<not>?ifB1 \<longrightarrow> (\<exists>stack.?puInv stack))"
      proof -
        {
          assume ifB1: "t = Null \<or> t^.m" and ifB2: "p^.c"
          from ifB1 whileB have pNotNull: "p \<noteq> Null" by auto
          then obtain addr_p where addr_p_eq: "p = Ref addr_p" by auto
          with i1 obtain stack_tl where stack_eq: "stack = (addr p) # stack_tl"
            by auto
          with i2 have m_addr_p: "p^.m" by auto
          have stackDist: "distinct (stack)" using i1 by (rule List_distinct)
          from stack_eq stackDist have p_notin_stack_tl: "addr p \<notin> set stack_tl" by simp
          let "?poI1\<and> ?poI2\<and> ?poI3\<and> ?poI4\<and> ?poI5\<and> ?poI6\<and> ?poI7" = "?popInv stack_tl"
          have "?popInv stack_tl"
          proof -

            \<comment> \<open>List property is maintained:\<close>
            from i1 p_notin_stack_tl ifB2
            have poI1: "List (S c l (r(p \<rightarrow> t))) (p^.r) stack_tl"
              by(simp add: addr_p_eq stack_eq, simp add: S_def)

            moreover
            \<comment> \<open>Everything on the stack is marked:\<close>
            from i2 have poI2: "\<forall> x \<in> set stack_tl. m x" by (simp add:stack_eq)
            moreover

            \<comment> \<open>Everything is still reachable:\<close>
            let "(R = reachable ?Ra ?A)" = "?I3"
            let "?Rb" = "(relS {l, r(p \<rightarrow> t)})"
            let "?B" = "{p, p^.r}"
            \<comment> \<open>Our goal is \<open>R = reachable ?Rb ?B\<close>.\<close>
            have "?Ra\<^sup>* `` addrs ?A = ?Rb\<^sup>* `` addrs ?B" (is "?L = ?R")
            proof
              show "?L \<subseteq> ?R"
              proof (rule still_reachable)
                show "addrs ?A \<subseteq> ?Rb\<^sup>* `` addrs ?B" by(fastforce simp:addrs_def relS_def rel_def addr_p_eq
                     intro:oneStep_reachable Image_iff[THEN iffD2])
                show "\<forall>(x,y) \<in> ?Ra-?Rb. y \<in> (?Rb\<^sup>* `` addrs ?B)" by (clarsimp simp:relS_def)
                     (fastforce simp add:rel_def Image_iff addrs_def dest:rel_upd1)
              qed
              show "?R \<subseteq> ?L"
              proof (rule still_reachable)
                show "addrs ?B \<subseteq> ?Ra\<^sup>* `` addrs ?A"
                  by(fastforce simp:addrs_def rel_defs addr_p_eq
                      intro:oneStep_reachable Image_iff[THEN iffD2])
              next
                show "\<forall>(x, y)\<in>?Rb-?Ra. y\<in>(?Ra\<^sup>*``addrs ?A)"
                  by (clarsimp simp:relS_def)
                     (fastforce simp add:rel_def Image_iff addrs_def dest:rel_upd2)
              qed
            qed
            with i3 have poI3: "R = reachable ?Rb ?B"  by (simp add:reachable_def)
            moreover

            \<comment> "If it is reachable and not marked, it is still reachable using..."
            let "\<forall>x. x \<in> R \<and> \<not> m x \<longrightarrow> x \<in> reachable ?Ra ?A"  =  ?I4
            let "?Rb" = "relS {l, r(p \<rightarrow> t)} | m"
            let "?B" = "{p} \<union> set (map (r(p \<rightarrow> t)) stack_tl)"
            \<comment> \<open>Our goal is \<open>\<forall>x. x \<in> R \<and> \<not> m x \<longrightarrow> x \<in> reachable ?Rb ?B\<close>.\<close>
            let ?T = "{t, p^.r}"

            have "?Ra\<^sup>* `` addrs ?A \<subseteq> ?Rb\<^sup>* `` (addrs ?B \<union> addrs ?T)"
            proof (rule still_reachable)
              have rewrite: "\<forall>s\<in>set stack_tl. (r(p \<rightarrow> t)) s = r s"
                by (auto simp add:p_notin_stack_tl intro:fun_upd_other)
              show "addrs ?A \<subseteq> ?Rb\<^sup>* `` (addrs ?B \<union> addrs ?T)"
                by (fastforce cong:map_cong simp:stack_eq addrs_def rewrite intro:self_reachable)
              show "\<forall>(x, y)\<in>?Ra-?Rb. y\<in>(?Rb\<^sup>*``(addrs ?B \<union> addrs ?T))"
                by (clarsimp simp:restr_def relS_def)
                  (fastforce simp add:rel_def Image_iff addrs_def dest:rel_upd1)
            qed
            \<comment> "We now bring a term from the right to the left of the subset relation."
            hence subset: "?Ra\<^sup>* `` addrs ?A - ?Rb\<^sup>* `` addrs ?T \<subseteq> ?Rb\<^sup>* `` addrs ?B"
              by blast
            have poI4: "\<forall>x. x \<in> R \<and> \<not> m x \<longrightarrow> x \<in> reachable ?Rb ?B"
            proof (rule allI, rule impI)
              fix x
              assume a: "x \<in> R \<and> \<not> m x"
              \<comment> \<open>First, a disjunction on @{term"p^.r"} used later in the proof\<close>
              have pDisj:"p^.r = Null \<or> (p^.r \<noteq> Null \<and> p^.r^.m)" using poI1 poI2
                by auto
              \<comment> \<open>@{term x} belongs to the left hand side of @{thm[source] subset}:\<close>
              have incl: "x \<in> ?Ra\<^sup>*``addrs ?A" using  a i4 by (simp only:reachable_def, clarsimp)
              have excl: "x \<notin> ?Rb\<^sup>*`` addrs ?T" using pDisj ifB1 a by (auto simp add:addrs_def)
              \<comment> \<open>And therefore also belongs to the right hand side of @{thm[source]subset},\<close>
              \<comment> \<open>which corresponds to our goal.\<close>
              from incl excl subset  show "x \<in> reachable ?Rb ?B" by (auto simp add:reachable_def)
            qed
            moreover

            \<comment> "If it is marked, then it is reachable"
            from i5 have poI5: "\<forall>x. m x \<longrightarrow> x \<in> R" .
            moreover

            \<comment> \<open>If it is not on the stack, then its @{term l} and @{term r} fields are unchanged\<close>
            from i7 i6 ifB2
            have poI6: "\<forall>x. x \<notin> set stack_tl \<longrightarrow> (r(p \<rightarrow> t)) x = iR x \<and> l x = iL x"
              by(auto simp: addr_p_eq stack_eq fun_upd_apply)

            moreover

            \<comment> \<open>If it is on the stack, then its @{term l} and @{term r} fields can be reconstructed\<close>
            from p_notin_stack_tl i7 have poI7: "stkOk c l (r(p \<rightarrow> t)) iL iR p stack_tl"
              by (clarsimp simp:stack_eq addr_p_eq)

            ultimately show "?popInv stack_tl" by simp
          qed
          hence "\<exists>stack. ?popInv stack" ..
        }
        moreover

        \<comment> "Proofs of the Swing and Push arm follow."
        \<comment> "Since they are in principle simmilar to the Pop arm proof,"
        \<comment> "we show fewer comments and use frequent pattern matching."
        {
          \<comment> "Swing arm"
          assume ifB1: "?ifB1" and nifB2: "\<not>?ifB2"
          from ifB1 whileB have pNotNull: "p \<noteq> Null" by clarsimp
          then obtain addr_p where addr_p_eq: "p = Ref addr_p" by clarsimp
          with i1 obtain stack_tl where stack_eq: "stack = (addr p) # stack_tl" by clarsimp
          with i2 have m_addr_p: "p^.m" by clarsimp
          from stack_eq stackDist have p_notin_stack_tl: "(addr p) \<notin> set stack_tl"
            by simp
          let "?swI1\<and>?swI2\<and>?swI3\<and>?swI4\<and>?swI5\<and>?swI6\<and>?swI7" = "?swInv stack"
          have "?swInv stack"
          proof -

            \<comment> \<open>List property is maintained:\<close>
            from i1 p_notin_stack_tl nifB2
            have swI1: "?swI1"
              by (simp add:addr_p_eq stack_eq, simp add:S_def)
            moreover

            \<comment> \<open>Everything on the stack is marked:\<close>
            from i2
            have swI2: "?swI2" .
            moreover

            \<comment> \<open>Everything is still reachable:\<close>
            let "R = reachable ?Ra ?A" = "?I3"
            let "R = reachable ?Rb ?B" = "?swI3"
            have "?Ra\<^sup>* `` addrs ?A = ?Rb\<^sup>* `` addrs ?B"
            proof (rule still_reachable_eq)
              show "addrs ?A \<subseteq> ?Rb\<^sup>* `` addrs ?B"
                by(fastforce simp:addrs_def rel_defs addr_p_eq intro:oneStep_reachable Image_iff[THEN iffD2])
            next
              show "addrs ?B \<subseteq> ?Ra\<^sup>* `` addrs ?A"
                by(fastforce simp:addrs_def rel_defs addr_p_eq intro:oneStep_reachable Image_iff[THEN iffD2])
            next
              show "\<forall>(x, y)\<in>?Ra-?Rb. y\<in>(?Rb\<^sup>*``addrs ?B)"
                by (clarsimp simp:relS_def) (fastforce simp add:rel_def Image_iff addrs_def fun_upd_apply dest:rel_upd1)
            next
              show "\<forall>(x, y)\<in>?Rb-?Ra. y\<in>(?Ra\<^sup>*``addrs ?A)"
                by (clarsimp simp:relS_def) (fastforce simp add:rel_def Image_iff addrs_def fun_upd_apply dest:rel_upd2)
            qed
            with i3
            have swI3: "?swI3" by (simp add:reachable_def)
            moreover

            \<comment> "If it is reachable and not marked, it is still reachable using..."
            let "\<forall>x. x \<in> R \<and> \<not> m x \<longrightarrow> x \<in> reachable ?Ra ?A" = ?I4
            let "\<forall>x. x \<in> R \<and> \<not> m x \<longrightarrow> x \<in> reachable ?Rb ?B" = ?swI4
            let ?T = "{t}"
            have "?Ra\<^sup>*``addrs ?A \<subseteq> ?Rb\<^sup>*``(addrs ?B \<union> addrs ?T)"
            proof (rule still_reachable)
              have rewrite: "(\<forall>s\<in>set stack_tl. (r(addr p := l(addr p))) s = r s)"
                by (auto simp add:p_notin_stack_tl intro:fun_upd_other)
              show "addrs ?A \<subseteq> ?Rb\<^sup>* `` (addrs ?B \<union> addrs ?T)"
                by (fastforce cong:map_cong simp:stack_eq addrs_def rewrite intro:self_reachable)
            next
              show "\<forall>(x, y)\<in>?Ra-?Rb. y\<in>(?Rb\<^sup>*``(addrs ?B \<union> addrs ?T))"
                by (clarsimp simp:relS_def restr_def) (fastforce simp add:rel_def Image_iff addrs_def fun_upd_apply dest:rel_upd1)
            qed
            then have subset: "?Ra\<^sup>*``addrs ?A - ?Rb\<^sup>*``addrs ?T \<subseteq> ?Rb\<^sup>*``addrs ?B"
              by blast
            have ?swI4
            proof (rule allI, rule impI)
              fix x
              assume a: "x \<in> R \<and>\<not> m x"
              with i4 addr_p_eq stack_eq  have inc: "x \<in> ?Ra\<^sup>*``addrs ?A"
                by (simp only:reachable_def, clarsimp)
              with ifB1 a
              have exc: "x \<notin> ?Rb\<^sup>*`` addrs ?T"
                by (auto simp add:addrs_def)
              from inc exc subset  show "x \<in> reachable ?Rb ?B"
                by (auto simp add:reachable_def)
            qed
            moreover

            \<comment> "If it is marked, then it is reachable"
            from i5
            have "?swI5" .
            moreover

            \<comment> \<open>If it is not on the stack, then its @{term l} and @{term r} fields are unchanged\<close>
            from i6 stack_eq
            have "?swI6"
              by clarsimp
            moreover

            \<comment> \<open>If it is on the stack, then its @{term l} and @{term r} fields can be reconstructed\<close>
            from stackDist i7 nifB2
            have "?swI7"
              by (clarsimp simp:addr_p_eq stack_eq)

            ultimately show ?thesis by auto
          qed
          then have "\<exists>stack. ?swInv stack" by blast
        }
        moreover

        {
          \<comment> "Push arm"
          assume nifB1: "\<not>?ifB1"
          from nifB1 whileB have tNotNull: "t \<noteq> Null" by clarsimp
          then obtain addr_t where addr_t_eq: "t = Ref addr_t" by clarsimp
          with i1 obtain new_stack where new_stack_eq: "new_stack = (addr t) # stack" by clarsimp
          from tNotNull nifB1 have n_m_addr_t: "\<not> (t^.m)" by clarsimp
          with i2 have t_notin_stack: "(addr t) \<notin> set stack" by blast
          let "?puI1\<and>?puI2\<and>?puI3\<and>?puI4\<and>?puI5\<and>?puI6\<and>?puI7" = "?puInv new_stack"
          have "?puInv new_stack"
          proof -

            \<comment> \<open>List property is maintained:\<close>
            from i1 t_notin_stack
            have puI1: "?puI1"
              by (simp add:addr_t_eq new_stack_eq, simp add:S_def)
            moreover

            \<comment> \<open>Everything on the stack is marked:\<close>
            from i2
            have puI2: "?puI2"
              by (simp add:new_stack_eq fun_upd_apply)
            moreover

            \<comment> \<open>Everything is still reachable:\<close>
            let "R = reachable ?Ra ?A" = "?I3"
            let "R = reachable ?Rb ?B" = "?puI3"
            have "?Ra\<^sup>* `` addrs ?A = ?Rb\<^sup>* `` addrs ?B"
            proof (rule still_reachable_eq)
              show "addrs ?A \<subseteq> ?Rb\<^sup>* `` addrs ?B"
                by(fastforce simp:addrs_def rel_defs addr_t_eq intro:oneStep_reachable Image_iff[THEN iffD2])
            next
              show "addrs ?B \<subseteq> ?Ra\<^sup>* `` addrs ?A"
                by(fastforce simp:addrs_def rel_defs addr_t_eq intro:oneStep_reachable Image_iff[THEN iffD2])
            next
              show "\<forall>(x, y)\<in>?Ra-?Rb. y\<in>(?Rb\<^sup>*``addrs ?B)"
                by (clarsimp simp:relS_def) (fastforce simp add:rel_def Image_iff addrs_def dest:rel_upd1)
            next
              show "\<forall>(x, y)\<in>?Rb-?Ra. y\<in>(?Ra\<^sup>*``addrs ?A)"
                by (clarsimp simp:relS_def) (fastforce simp add:rel_def Image_iff addrs_def fun_upd_apply dest:rel_upd2)
            qed
            with i3
            have puI3: "?puI3" by (simp add:reachable_def)
            moreover

            \<comment> "If it is reachable and not marked, it is still reachable using..."
            let "\<forall>x. x \<in> R \<and> \<not> m x \<longrightarrow> x \<in> reachable ?Ra ?A" = ?I4
            let "\<forall>x. x \<in> R \<and> \<not> ?new_m x \<longrightarrow> x \<in> reachable ?Rb ?B" = ?puI4
            let ?T = "{t}"
            have "?Ra\<^sup>*``addrs ?A \<subseteq> ?Rb\<^sup>*``(addrs ?B \<union> addrs ?T)"
            proof (rule still_reachable)
              show "addrs ?A \<subseteq> ?Rb\<^sup>* `` (addrs ?B \<union> addrs ?T)"
                by (fastforce simp:new_stack_eq addrs_def intro:self_reachable)
            next
              show "\<forall>(x, y)\<in>?Ra-?Rb. y\<in>(?Rb\<^sup>*``(addrs ?B \<union> addrs ?T))"
                by (clarsimp simp:relS_def new_stack_eq restr_un restr_upd)
                   (fastforce simp add:rel_def Image_iff restr_def addrs_def fun_upd_apply addr_t_eq dest:rel_upd3)
            qed
            then have subset: "?Ra\<^sup>*``addrs ?A - ?Rb\<^sup>*``addrs ?T \<subseteq> ?Rb\<^sup>*``addrs ?B"
              by blast
            have ?puI4
            proof (rule allI, rule impI)
              fix x
              assume a: "x \<in> R \<and> \<not> ?new_m x"
              have xDisj: "x=(addr t) \<or> x\<noteq>(addr t)" by simp
              with i4 a have inc: "x \<in> ?Ra\<^sup>*``addrs ?A"
                by (fastforce simp:addr_t_eq addrs_def reachable_def intro:self_reachable)
              have exc: "x \<notin> ?Rb\<^sup>*`` addrs ?T"
                using xDisj a n_m_addr_t
                by (clarsimp simp add:addrs_def addr_t_eq)
              from inc exc subset  show "x \<in> reachable ?Rb ?B"
                by (auto simp add:reachable_def)
            qed
            moreover

            \<comment> "If it is marked, then it is reachable"
            from i5
            have "?puI5"
              by (auto simp:addrs_def i3 reachable_def addr_t_eq fun_upd_apply intro:self_reachable)
            moreover

            \<comment> \<open>If it is not on the stack, then its @{term l} and @{term r} fields are unchanged\<close>
            from i6
            have "?puI6"
              by (simp add:new_stack_eq)
            moreover

            \<comment> \<open>If it is on the stack, then its @{term l} and @{term r} fields can be reconstructed\<close>
            from stackDist i6 t_notin_stack i7
            have "?puI7" by (clarsimp simp:addr_t_eq new_stack_eq)

            ultimately show ?thesis by auto
          qed
          then have "\<exists>stack. ?puInv stack" by blast

        }
        ultimately show ?thesis by blast
      qed
    }
  qed

end


(* Author: Dmitriy Traytel *)

section \<open>$\Pi$-Extended Regular Expressions\<close>

(*<*)
theory Pi_Regular_Exp
imports Pi_Regular_Set "HOL-Library.List_Lexorder" "HOL-Library.Code_Target_Nat"
  Deriving.Compare_Instances
begin
(*>*)
subsection \<open>Syntax of regular expressions\<close>

datatype 'a rexp =
  Zero |
  Full |
  One |
  Atom 'a |
  Plus "('a rexp)" "('a rexp)" |
  Times "('a rexp)" "('a rexp)" |
  Star "('a rexp)" |
  Not "('a rexp)" |
  Inter "('a rexp)" "('a rexp)" |
  Pr "('a rexp)"
derive linorder rexp

text \<open>Lifting constructors to lists\<close>

fun rexp_of_list where
  "rexp_of_list OPERATION N [] = N"
| "rexp_of_list OPERATION N [x] = x"
| "rexp_of_list OPERATION N (x # xs) = OPERATION x (rexp_of_list OPERATION N xs)"

abbreviation "PLUS \<equiv> rexp_of_list Plus Zero"
abbreviation "TIMES \<equiv> rexp_of_list Times One"
abbreviation "INTERSECT \<equiv> rexp_of_list Inter Full"

lemma list_singleton_induct [case_names nil single cons]:
  assumes nil: "P []"
  assumes single: "\<And>x. P [x]"
  assumes cons: "\<And>x y xs. P (y # xs) \<Longrightarrow> P (x # (y # xs))"
  shows "P xs"
  using assms
proof (induct xs)
  case (Cons x xs) thus ?case by (cases xs) auto
qed simp

subsection \<open>ACI normalization\<close>

fun toplevel_summands :: "'a rexp \<Rightarrow> 'a rexp set" where
  "toplevel_summands (Plus r s) = toplevel_summands r \<union> toplevel_summands s"
| "toplevel_summands r = {r}"

abbreviation (input) "flatten LISTOP X \<equiv> LISTOP (sorted_list_of_set X)"

lemma toplevel_summands_nonempty[simp]:
  "toplevel_summands r \<noteq> {}"
  by (induct r) auto

lemma toplevel_summands_finite[simp]:
  "finite (toplevel_summands r)"
  by (induct r) auto

primrec ACI_norm :: "('a::linorder) rexp \<Rightarrow> 'a rexp"  ("\<guillemotleft>_\<guillemotright>") where
  "\<guillemotleft>Zero\<guillemotright> = Zero"
| "\<guillemotleft>Full\<guillemotright> = Full"
| "\<guillemotleft>One\<guillemotright> = One"
| "\<guillemotleft>Atom a\<guillemotright> = Atom a"
| "\<guillemotleft>Plus r s\<guillemotright> = flatten PLUS (toplevel_summands (Plus \<guillemotleft>r\<guillemotright> \<guillemotleft>s\<guillemotright>))"
| "\<guillemotleft>Times r s\<guillemotright> = Times \<guillemotleft>r\<guillemotright> \<guillemotleft>s\<guillemotright>"
| "\<guillemotleft>Star r\<guillemotright> = Star \<guillemotleft>r\<guillemotright>"
| "\<guillemotleft>Not r\<guillemotright> = Not \<guillemotleft>r\<guillemotright>"
| "\<guillemotleft>Inter r s\<guillemotright> = Inter \<guillemotleft>r\<guillemotright> \<guillemotleft>s\<guillemotright>"
| "\<guillemotleft>Pr r\<guillemotright> = Pr \<guillemotleft>r\<guillemotright>"

lemma Plus_toplevel_summands:
  "Plus r s \<in> toplevel_summands t \<Longrightarrow> False"
  by (induct t) auto

lemma toplevel_summands_not_Plus[simp]:
  "(\<forall>r s. x \<noteq> Plus r s) \<Longrightarrow> toplevel_summands x = {x}"
  by (induct x) auto

lemma toplevel_summands_PLUS_strong:
  "\<lbrakk>xs \<noteq> []; list_all (\<lambda>x. \<not>(\<exists>r s. x = Plus r s)) xs\<rbrakk> \<Longrightarrow> toplevel_summands (PLUS xs) = set xs"
  by (induct xs rule: list_singleton_induct) auto

lemma toplevel_summands_flatten:
  "\<lbrakk>X \<noteq> {}; finite X; \<forall>x \<in> X. \<not>(\<exists>r s. x = Plus r s)\<rbrakk> \<Longrightarrow> toplevel_summands (flatten PLUS X) = X"
  using toplevel_summands_PLUS_strong[of "sorted_list_of_set X"]
  unfolding list_all_iff by fastforce

lemma ACI_norm_Plus:
  "\<guillemotleft>r\<guillemotright> = Plus s t \<Longrightarrow> \<exists>s t. r = Plus s t"
  by (induct r) auto

lemma toplevel_summands_flatten_ACI_norm_image:
  "toplevel_summands (flatten PLUS (ACI_norm ` toplevel_summands r)) = ACI_norm ` toplevel_summands r"
  by (intro toplevel_summands_flatten) (auto dest!: ACI_norm_Plus intro: Plus_toplevel_summands)

lemma toplevel_summands_flatten_ACI_norm_image_Union:
  "toplevel_summands (flatten PLUS (ACI_norm ` toplevel_summands r \<union> ACI_norm ` toplevel_summands s)) =
    ACI_norm ` toplevel_summands r \<union> ACI_norm ` toplevel_summands s"
  by (intro toplevel_summands_flatten) (auto dest!: ACI_norm_Plus[OF sym] intro: Plus_toplevel_summands)

lemma toplevel_summands_ACI_norm:
  "toplevel_summands \<guillemotleft>r\<guillemotright> = ACI_norm ` toplevel_summands r"
  by (induct r) (auto simp: toplevel_summands_flatten_ACI_norm_image_Union)

lemma ACI_norm_flatten:
  "\<guillemotleft>r\<guillemotright> = flatten PLUS (ACI_norm ` toplevel_summands r)"
  by (induct r) (auto simp: image_Un toplevel_summands_flatten_ACI_norm_image)

theorem ACI_norm_idem[simp]:
  "\<guillemotleft>\<guillemotleft>r\<guillemotright>\<guillemotright> = \<guillemotleft>r\<guillemotright>"
proof (induct r)
  case (Plus r s)
  have "\<guillemotleft>\<guillemotleft>Plus r s\<guillemotright>\<guillemotright> = \<guillemotleft>flatten PLUS (toplevel_summands \<guillemotleft>r\<guillemotright> \<union> toplevel_summands \<guillemotleft>s\<guillemotright>)\<guillemotright>"
    (is "_ = \<guillemotleft>flatten PLUS ?U\<guillemotright>") by simp
  also have "\<dots> = flatten PLUS (ACI_norm ` toplevel_summands (flatten PLUS ?U))"
    by (simp only: ACI_norm_flatten)
  also have "toplevel_summands (flatten PLUS ?U) = ?U"
    by (intro toplevel_summands_flatten) (auto intro: Plus_toplevel_summands)
  also have "flatten PLUS (ACI_norm ` ?U) = flatten PLUS (toplevel_summands \<guillemotleft>r\<guillemotright> \<union> toplevel_summands \<guillemotleft>s\<guillemotright>)"
    by (simp only: image_Un toplevel_summands_ACI_norm[symmetric] Plus)
  finally show ?case by simp
qed auto

fun ACI_nPlus :: "'a::linorder rexp \<Rightarrow> 'a rexp \<Rightarrow> 'a rexp"
where
  "ACI_nPlus (Plus r1 r2) s = ACI_nPlus r1 (ACI_nPlus r2 s)"
| "ACI_nPlus r (Plus s1 s2) =
  (if r = s1 then Plus s1 s2
  else if r < s1 then Plus r (Plus s1 s2)
  else Plus s1 (ACI_nPlus r s2))"
| "ACI_nPlus r s =
  (if r = s then r
  else if r < s then Plus r s
  else Plus s r)"

fun ACI_norm_alt where
  "ACI_norm_alt Zero = Zero"
| "ACI_norm_alt Full = Full"
| "ACI_norm_alt One = One"
| "ACI_norm_alt (Atom a) = Atom a"
| "ACI_norm_alt (Plus r s) = ACI_nPlus (ACI_norm_alt r) (ACI_norm_alt s)"
| "ACI_norm_alt (Times r s) = Times (ACI_norm_alt r) (ACI_norm_alt s)"
| "ACI_norm_alt (Star r) = Star (ACI_norm_alt r)"
| "ACI_norm_alt (Not r) = Not (ACI_norm_alt r)"
| "ACI_norm_alt (Inter r s) = Inter (ACI_norm_alt r) (ACI_norm_alt s)"
| "ACI_norm_alt (Pr r) = Pr (ACI_norm_alt r)"

lemma toplevel_summands_ACI_nPlus:
  "toplevel_summands (ACI_nPlus r s) = toplevel_summands (Plus r s)"
  by (induct r s rule: ACI_nPlus.induct) auto

lemma toplevel_summands_ACI_norm_alt:
  "toplevel_summands (ACI_norm_alt r) = ACI_norm_alt ` toplevel_summands r"
  by (induct r) (auto simp: toplevel_summands_ACI_nPlus)

lemma ACI_norm_alt_Plus:
  "ACI_norm_alt r = Plus s t \<Longrightarrow> \<exists>s t. r = Plus s t"
  by (induct r) auto

lemma toplevel_summands_flatten_ACI_norm_alt_image:
  "toplevel_summands (flatten PLUS (ACI_norm_alt ` toplevel_summands r)) = ACI_norm_alt ` toplevel_summands r"
  by (intro toplevel_summands_flatten) (auto dest!: ACI_norm_alt_Plus intro: Plus_toplevel_summands)

lemma ACI_norm_ACI_norm_alt: "\<guillemotleft>ACI_norm_alt r\<guillemotright> = \<guillemotleft>r\<guillemotright>"
proof (induction r)
  case (Plus r s) show ?case
    using ACI_norm_flatten [of "ACI_norm_alt (Plus r s)"] ACI_norm_flatten [of "Plus r s"]
    by (auto simp: image_Un toplevel_summands_ACI_nPlus)
      (metis Plus.IH toplevel_summands_ACI_norm)
qed auto

lemma ACI_nPlus_singleton_PLUS:
  "\<lbrakk>xs \<noteq> []; sorted xs; distinct xs; \<forall>x \<in> {x} \<union> set xs. \<not>(\<exists>r s. x = Plus r s)\<rbrakk> \<Longrightarrow>
  ACI_nPlus x (PLUS xs) = (if x \<in> set xs then PLUS xs else PLUS (insort x xs))"
proof (induct xs rule: list_singleton_induct)
  case (single y)
  thus ?case
    by (cases x y rule: linorder_cases) (induct x y rule: ACI_nPlus.induct, auto)+
next
  case (cons y1 y2 ys) thus ?case by (cases x) (auto)
qed simp

lemma ACI_nPlus_PLUS:
  "\<lbrakk>xs1 \<noteq> []; xs2 \<noteq> []; \<forall>x \<in> set (xs1 @ xs2). \<not>(\<exists>r s. x = Plus r s); sorted xs2; distinct xs2\<rbrakk>\<Longrightarrow>
  ACI_nPlus (PLUS xs1) (PLUS xs2) = flatten PLUS (set (xs1 @ xs2))"
proof (induct xs1 arbitrary: xs2 rule: list_singleton_induct)
  case (single x1) thus ?case
    apply (auto intro!: trans[OF ACI_nPlus_singleton_PLUS] simp: insert_absorb simp del: sorted_list_of_set_insert)
     apply (metis finite_set finite_sorted_distinct_unique sorted_list_of_set)
    apply (metis remdups_id_iff_distinct sorted_list_of_set_sort_remdups sorted_sort_id)
    done
next
  case (cons x11 x12 xs1) thus ?case
    apply (simp del: sorted_list_of_set_insert)
    apply (rule trans[OF ACI_nPlus_singleton_PLUS])
         apply (auto simp del: sorted_list_of_set_insert simp add: insert_commute[of x11])
       apply (auto simp only: Un_insert_left[of x11, symmetric] insert_absorb) []
      apply (auto simp only: Un_insert_right[of _ x11, symmetric] insert_absorb) []
     apply (auto simp add: insert_commute[of x12])
  done
qed simp

lemma ACI_nPlus_flatten_PLUS:
  "\<lbrakk>X1 \<noteq> {}; X2 \<noteq> {}; finite X1; finite X2; \<forall>x \<in> X1 \<union> X2. \<not>(\<exists>r s. x = Plus r s)\<rbrakk>\<Longrightarrow>
  ACI_nPlus (flatten PLUS X1) (flatten PLUS X2) = flatten PLUS (X1 \<union> X2)"
  by (rule trans[OF ACI_nPlus_PLUS]) auto

lemma ACI_nPlus_ACI_norm[simp]: "ACI_nPlus \<guillemotleft>r\<guillemotright> \<guillemotleft>s\<guillemotright> = \<guillemotleft>Plus r s\<guillemotright>"
  using ACI_norm_flatten [of r] ACI_norm_flatten [of s] ACI_norm_flatten [of "Plus r s"]
  apply (auto intro!: trans [OF ACI_nPlus_flatten_PLUS])
    apply (auto simp: image_Un Un_assoc  intro!: trans [OF ACI_nPlus_flatten_PLUS])
   apply (metis ACI_norm_Plus Plus_toplevel_summands)+
  done

lemma ACI_norm_alt:
  "ACI_norm_alt r = \<guillemotleft>r\<guillemotright>"
  by (induct r) auto

declare ACI_norm_alt[symmetric, code]

subsection \<open>Finality\<close>

primrec final :: "'a rexp \<Rightarrow> bool"
where
  "final Zero = False"
| "final Full = True"
| "final One = True"
| "final (Atom _) = False"
| "final (Plus r s) = (final r \<or> final s)"
| "final (Times r s) = (final r \<and> final s)"
| "final (Star _) = True"
| "final (Not r) = (~ final r)"
| "final (Inter r1 r2) = (final r1 \<and> final r2)"
| "final (Pr r) = final r"

lemma toplevel_summands_final:
  "final s = (\<exists>r\<in>toplevel_summands s. final r)"
  by (induct s) auto

lemma final_PLUS:
  "final (PLUS xs) = (\<exists>r \<in> set xs. final r)"
  by (induct xs rule: list_singleton_induct) auto

theorem ACI_norm_final[simp]:
  "final \<guillemotleft>r\<guillemotright> = final r"
proof (induct r)
  case (Plus r1 r2) thus ?case using toplevel_summands_final by (auto simp: final_PLUS)
qed auto

subsection \<open>Wellformedness w.r.t. an alphabet\<close>

locale alphabet =
fixes \<Sigma> :: "nat \<Rightarrow> 'a set" ("\<Sigma> _")
and wf_atom :: "nat \<Rightarrow> 'b :: linorder \<Rightarrow> bool"
begin

primrec wf :: "nat \<Rightarrow> 'b rexp \<Rightarrow> bool"
where
"wf n Zero = True" |
"wf n Full = True" |
"wf n One = True" |
"wf n (Atom a) = (wf_atom n a)" |
"wf n (Plus r s) = (wf n r \<and> wf n s)" |
"wf n (Times r s) = (wf n r \<and> wf n s)" |
"wf n (Star r) = wf n r" |
"wf n (Not r) = wf n r" |
"wf n (Inter r s) = (wf n r \<and> wf n s)" |
"wf n (Pr r) = wf (n + 1) r"

primrec wf_word where
  "wf_word n [] = True"
| "wf_word n (w # ws) = ((w \<in> \<Sigma> n) \<and> wf_word n ws)"

lemma wf_word_snoc[simp]: "wf_word n (ws @ [w]) = ((w \<in> \<Sigma> n) \<and> wf_word n ws)"
  by (induct ws) auto

lemma wf_word_append[simp]: "wf_word n (ws @ vs) = (wf_word n ws \<and> wf_word n vs)"
  by (induct ws arbitrary: vs) auto

lemma wf_word: "wf_word n w = (w \<in> lists (\<Sigma> n))"
  by (induct w) auto

lemma wf_PLUS[simp]:
  "wf n (PLUS xs) = (\<forall>r \<in> set xs. wf n r)"
  by (induct xs rule: list_singleton_induct) auto

lemma wf_TIMES[simp]:
  "wf n (TIMES xs) = (\<forall>r \<in> set xs. wf n r)"
  by (induct xs rule: list_singleton_induct) auto

lemma wf_flatten_PLUS[simp]:
  "finite X \<Longrightarrow> wf n (flatten PLUS X) = (\<forall>r \<in> X. wf n r)"
  using wf_PLUS[of n "sorted_list_of_set X"] by fastforce

theorem ACI_norm_wf[simp]:
  "wf n \<guillemotleft>r\<guillemotright> = wf n r"
proof (induct r arbitrary: n)
  case (Plus r1 r2) thus ?case
   using toplevel_summands_wf[of n "\<guillemotleft>r1\<guillemotright>"] toplevel_summands_wf[of n "\<guillemotleft>r2\<guillemotright>"] by auto
qed auto

lemma wf_INTERSECT[simp]:
  "wf n (INTERSECT xs) = (\<forall>r \<in> set xs. wf n r)"
  by (induct xs rule: list_singleton_induct) auto

lemma wf_flatten_INTERSECT[simp]:
  "finite X \<Longrightarrow> wf n (flatten INTERSECT X) = (\<forall>r \<in> X. wf n r)"
  using wf_INTERSECT[of n "sorted_list_of_set X"] by fastforce

end

subsection \<open>Language\<close>

locale project =
  alphabet \<Sigma> wf_atom for \<Sigma> :: "nat \<Rightarrow> 'a set" and wf_atom :: "nat \<Rightarrow> 'b :: linorder \<Rightarrow> bool" +
fixes project :: "'a \<Rightarrow> 'a"
and lookup :: "'b \<Rightarrow> 'a \<Rightarrow> bool"
assumes project: "\<And>a. a \<in> \<Sigma> (Suc n) \<Longrightarrow> project a \<in> \<Sigma> n"
begin

primrec lang :: "nat \<Rightarrow> 'b rexp => 'a lang" where
"lang n Zero = {}" |
"lang n Full = lists (\<Sigma> n)" |
"lang n One = {[]}" |
"lang n (Atom b) = {[x] | x. lookup b x \<and> x \<in> \<Sigma> n}" |
"lang n (Plus r s) = (lang n r) \<union> (lang n s)" |
"lang n (Times r s) = conc (lang n r) (lang n s)" |
"lang n (Star r) = star (lang n r)" |
"lang n (Not r) = lists (\<Sigma> n) - lang n r" |
"lang n (Inter r s) = (lang n r \<inter> lang n s)" |
"lang n (Pr r) = map project ` lang (n + 1) r"

lemma wf_word_map_project[simp]: "wf_word (Suc n) ws \<Longrightarrow> wf_word n (map project ws)"
  by (induct ws arbitrary: n) (auto intro: project)

lemma lang_subset_lists: "wf n r \<Longrightarrow> lang n r \<subseteq> lists (\<Sigma> n)"
proof (induct r arbitrary: n)
  case Pr thus ?case by (fastforce intro!: project)
qed (auto simp: conc_subset_lists star_subset_lists)

lemma toplevel_summands_lang:
  "r \<in> toplevel_summands s \<Longrightarrow> lang n r \<subseteq> lang n s"
  by (induct s) auto

lemma toplevel_summands_lang_UN:
  "lang n s = (\<Union>r\<in>toplevel_summands s. lang n r)"
  by (induct s) auto

lemma toplevel_summands_in_lang:
  "w \<in> lang n s = (\<exists>r\<in>toplevel_summands s. w \<in> lang n r)"
  by (induct s) auto

lemma lang_PLUS[simp]:
  "lang n (PLUS xs) = (\<Union>r \<in> set xs. lang n r)"
  by (induct xs rule: list_singleton_induct) auto

lemma lang_TIMES[simp]:
  "lang n (TIMES xs) = foldr (@@) (map (lang n) xs) {[]}"
  by (induct xs rule: list_singleton_induct) auto

lemma lang_flatten_PLUS:
  "finite X \<Longrightarrow> lang n (flatten PLUS X) = (\<Union>r \<in> X. lang n r)"
  using lang_PLUS[of n "sorted_list_of_set X"] by fastforce

theorem ACI_norm_lang[simp]:
  "lang n \<guillemotleft>r\<guillemotright> = lang n r"
proof (induct r arbitrary: n)
  case (Plus r1 r2)
  moreover
  from Plus[symmetric] have "lang n (Plus r1 r2) \<subseteq> lang n \<guillemotleft>Plus r1 r2\<guillemotright>"
    using toplevel_summands_in_lang[of _ n "\<guillemotleft>r1\<guillemotright>"] toplevel_summands_in_lang[of _ n "\<guillemotleft>r2\<guillemotright>"]
    by auto
  ultimately show ?case by (fastforce dest!: toplevel_summands_lang)
qed auto

lemma lang_final: "final r = ([] \<in> lang n r)"
  using concI[of "[]" _ "[]"] by (induct r arbitrary: n) auto

lemma in_lang_INTERSECT:
  "wf_word n w \<Longrightarrow> w \<in> lang n (INTERSECT xs) = (\<forall>r \<in> set xs. w \<in> lang n r)"
  by (induct xs rule: list_singleton_induct) (auto simp: wf_word)

lemma lang_INTERSECT:
  "lang n (INTERSECT xs) = (if xs = [] then lists (\<Sigma> n) else \<Inter>r \<in> set xs. lang n r)"
  by (induct xs rule: list_singleton_induct) auto

lemma lang_flatten_INTERSECT[simp]:
  assumes "finite X" "X \<noteq> {}" "\<forall>r\<in>X. wf n r"
  shows "w \<in> lang n (flatten INTERSECT X) = (\<forall>r \<in> X. w \<in> lang n r)" (is "?L = ?R")
proof
  assume ?L
  thus ?R using in_lang_INTERSECT[OF bspec[OF wf_lang_wf_word[OF iffD2[OF wf_flatten_INTERSECT]]],
    OF assms(1,3) \<open>?L\<close>, of "sorted_list_of_set X"] assms(1)
    by auto
next
  assume ?R
  with assms show ?L by (intro iffD2[OF in_lang_INTERSECT]) (auto dest: wf_lang_wf_word)
qed

end

(*<*)
end
(*>*)


theory regexp_RecStar
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 null :: "'a list => bool" where
"null (Nil2) = True"
| "null (Cons2 y z) = False"

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 null eqA and2 eps epsR step recognise *)

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

end


(*  Title:      HOL/Library/Sum_of_Squares_Remote.thy
    Author:     Amine Chaieb, University of Cambridge
    Author:     Philipp Meyer, TU Muenchen
*)

section {* Examples with remote CSDP *}

theory Sum_of_Squares_Remote
imports Sum_of_Squares
begin

lemma "(3::real) * x + 7 * a < 4 & 3 < 2 * x \<Longrightarrow> a < 0"
  by (sos remote_csdp)

lemma "a1 >= 0 & a2 >= 0 \<and> (a1 * a1 + a2 * a2 = b1 * b1 + b2 * b2 + 2) \<and> (a1 * b1 + a2 * b2 = 0) --> a1 * a2 - b1 * b2 >= (0::real)"
  by (sos remote_csdp)

lemma "(3::real) * x + 7 * a < 4 & 3 < 2 * x --> a < 0"
  by (sos remote_csdp)

lemma "(0::real) <= x & x <= 1 & 0 <= y & y <= 1  --> x^2 + y^2 < 1 |(x - 1)^2 + y^2 < 1 | x^2 + (y - 1)^2 < 1 | (x - 1)^2 + (y - 1)^2 < 1"
  by (sos remote_csdp)

lemma "(0::real) <= x & 0 <= y & 0 <= z & x + y + z <= 3 --> x * y + x * z + y * z >= 3 * x * y * z"
  by (sos remote_csdp)

lemma "((x::real)^2 + y^2 + z^2 = 1) --> (x + y + z)^2 <= 3"
  by (sos remote_csdp)

lemma "(w^2 + x^2 + y^2 + z^2 = 1) --> (w + x + y + z)^2 <= (4::real)"
  by (sos remote_csdp)

lemma "(x::real) >= 1 & y >= 1 --> x * y >= x + y - 1"
  by (sos remote_csdp)

end


chapter \<open>Congruence Closure Algorithm with Explain Operation\<close>
theory CC_Definition
  imports
    "../Union_Find_Explain/Explain_Correctness"
begin

section \<open>Definitions\<close>

text \<open>The input equations to this congruence closure algorithm need
      to be curryfied and flattened into terms of depth at most 2,
      by introducing the "apply" function \<open>f\<close> and new constants.

      The constants of the equation are represented by natural numbers,
      so that they can be also used as index of the union-find array.
      Each natural number represents an arbitrary constant,
      which is not related to the number it is represented by.

      For example the equation \<open>2 \<approx> 5\<close> should be interpreted as \<open>c\<^sub>2 = c\<^sub>5\<close>.\<close>

datatype equation = Constants nat nat ("_ \<approx> _" 51)
  | Function nat nat nat                 ("F _ _ \<approx> _" 51)

datatype pending_equation = One equation
  | Two equation equation

term "a \<approx> b"
term "if (F a b \<approx> c) = F a b \<approx> c then False else True"
term "(F a b \<approx> c) = (F a b \<approx> c)"

text \<open>Data structure for the congruence closure operations (merge, are_congruent and explain):
  \<open>cc_list\<close>: parents of the union-find-like tree data structure without path compression
  \<open>use_list\<close>: for each representative \<open>a\<close>, a list if input equations \<open>f b\<^sub>1 b\<^sub>2 = b\<close>,
              where \<open>a\<close> is the representative of either \<open>b\<^sub>1\<close> or \<open>b\<^sub>2\<close>.
  \<open>lookup\<close>: table indexed by pairs of representatives \<open>b\<close> and \<open>c\<close>,
            which stores an input equation \<open>f a\<^sub>1 a\<^sub>2 = a\<close> s.t.
            \<open>b\<close> and \<open>c\<close> are representatives of \<open>a\<^sub>1\<close> and \<open>a\<^sub>2\<close> respectively,
            or None if no such equation exists.
  \<open>pending\<close>: a list whose elements are input equations a=b, or pairs of input equations
             (f(a1, a2)=a, f(b1, b2)=b) where ai and bi are already congruent for i in {1, 2}.
  \<open>proof_forest\<close>: tree-shaped graph, with the sequence of merge operations as edges
  \<open>pf_labels\<close>: for each edge in the \<open>proof_forest\<close>, a label with the input equations
  \<open>input\<close>: a set of the input equation, useful for proofs
\<close>
record congruence_closure =
  cc_list :: "nat list"
  use_list :: "equation list list"
  lookup :: "equation option list list"
  pending :: "pending_equation list"
  proof_forest :: "nat list"
  pf_labels :: "pending_equation option list"
  input :: "equation set"

text \<open>For updating two dimensional lists.\<close>
abbreviation upd :: "'a list list \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a list list"
  where
"upd xs n m e \<equiv> xs[n := (xs ! n)[m := e]]"

text \<open>Finds the entry in the lookup table for the representatives of \<open>a\<^sub>1\<close> and \<open>a\<^sub>2\<close>.\<close>
abbreviation lookup_entry :: "equation option list list \<Rightarrow> nat list \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> equation option"
  where
"lookup_entry t l a\<^sub>1 a\<^sub>2 \<equiv> t ! rep_of l a\<^sub>1 ! rep_of l a\<^sub>2"

fun lookup_Some :: "equation option list list \<Rightarrow> nat list \<Rightarrow> equation \<Rightarrow> bool"
  where
"lookup_Some t l (F a\<^sub>1 a\<^sub>2 \<approx> a) = (\<not>Option.is_none (lookup_entry t l a\<^sub>1 a\<^sub>2))"
| "lookup_Some t l (a \<approx> b) = False"

\<comment> \<open>Should only be used if \<open>lookup(a\<^sub>1, a\<^sub>2)\<close> is not None and if the equation is not of the type (a = b)\<close>
fun link_to_lookup :: "equation option list list \<Rightarrow> nat list \<Rightarrow> equation \<Rightarrow> pending_equation"
  where
"link_to_lookup t l (F a\<^sub>1 a\<^sub>2 \<approx> a) = Two (F a\<^sub>1 a\<^sub>2 \<approx> a) (the (lookup_entry t l a\<^sub>1 a\<^sub>2))"
  \<comment> \<open>This should not be invoked.\<close>
| "link_to_lookup t l (a \<approx> b) = One (a \<approx> b)"

\<comment> \<open>Should only be used if \<open>lookup(a\<^sub>1, a\<^sub>2)\<close> is not None and if the equation is not of the type (a = b)\<close>
fun update_lookup :: "equation option list list \<Rightarrow> nat list \<Rightarrow> equation \<Rightarrow> equation option list list"
  where
"update_lookup t l (F c\<^sub>1 c\<^sub>2 \<approx> c) = upd t (rep_of l c\<^sub>1) (rep_of l c\<^sub>2) (Some (F c\<^sub>1 c\<^sub>2 \<approx> c))"
  \<comment> \<open>This should not be invoked.\<close>
| "update_lookup t l (a \<approx> b) = t"

fun left :: "pending_equation \<Rightarrow> nat"
  where
"left (One (a \<approx> b)) = a"
| "left (Two (F a\<^sub>1 a\<^sub>2 \<approx> a) (F b\<^sub>1 b\<^sub>2 \<approx> b)) = a"
  \<comment> \<open>This should not be invoked.\<close>
| "left a = undefined"

fun right :: "pending_equation \<Rightarrow> nat"
  where
"right (One (a \<approx> b)) = b"
| "right (Two (F a\<^sub>1 a\<^sub>2 \<approx> a) (F b\<^sub>1 b\<^sub>2 \<approx> b)) = b"
  \<comment> \<open>This should not be invoked.\<close>
| "right a = undefined"

text \<open>Implementation of the proof forest\<close>

function (domintros) add_edge :: "nat list \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat list"
  where
"add_edge pf e e' = (if pf ! e = e then (pf[e := e']) else add_edge (pf[e := e']) (pf ! e) e)"
  by pat_completeness auto

lemma add_edge_rel: "rep_of_rel (l, x) (l, y) \<longleftrightarrow> add_edge_rel (l[y := y'], x, y) (l, y, y')"
proof
  show "rep_of_rel (l, x) (l, y) \<Longrightarrow> add_edge_rel (l[y := y'], x, y) (l, y, y')"
    by (induction "(l, x)" "(l, y)" rule: rep_of_rel.induct)(auto simp add: add_edge_rel.intros)
next
  show "add_edge_rel (l[y := y'], x, y) (l, y, y') \<Longrightarrow> rep_of_rel (l, x) (l, y)"
    by (induction "(l[y := y'], x, y)" "(l, y, y')" rule: add_edge_rel.induct) (auto simp add: rep_of_rel.intros)
qed

function (domintros) add_label :: "pending_equation option list \<Rightarrow> nat list \<Rightarrow> nat \<Rightarrow> pending_equation \<Rightarrow> pending_equation option list"
  where
"add_label pfl pf e lbl = (if pf ! e = e then (pfl[e := Some lbl]) else add_label (pfl[e := Some lbl]) pf (pf ! e) (the (pfl ! e)))"
  by pat_completeness auto

fun propagate_loop
  where
"propagate_loop rep_b (u1 # urest)
\<lparr>cc_list = l, use_list = u, lookup = t, pending = pe, proof_forest = pf, pf_labels = pfl, input = ip\<rparr>
=
  propagate_loop rep_b urest (
    if (lookup_Some t l u1)
    then
      \<lparr>cc_list = l, use_list = u, lookup = t,
            pending = link_to_lookup t l u1#pe,
            proof_forest = pf, pf_labels = pfl, input = ip\<rparr>
    else
      \<lparr>cc_list = l,
            use_list = u[rep_b := u1 # (u ! rep_b)],
            lookup = update_lookup t l u1,
            pending = pe, proof_forest = pf, pf_labels = pfl, input = ip\<rparr>
)"
| "propagate_loop _ [] cc = cc"

abbreviation propagate_step
  where
"propagate_step l u t pe pf pfl ip a b eq \<equiv>
  propagate_loop (rep_of l b) (u ! rep_of l a)
    \<lparr>cc_list = ufa_union l a b,
    use_list = u[rep_of l a := []],
    lookup = t,
    pending = pe,
    proof_forest = add_edge pf a b,
    pf_labels = add_label pfl pf a eq,
    input = ip\<rparr>"

function (domintros) propagate :: "congruence_closure \<Rightarrow> congruence_closure"
  where
"propagate \<lparr>cc_list = l, use_list = u, lookup = t, pending = [], proof_forest = pf, pf_labels = pfl, input = ip\<rparr> =
\<lparr>cc_list = l, use_list = u, lookup = t, pending = [], proof_forest = pf, pf_labels = pfl, input = ip\<rparr>"
| "propagate
\<lparr>cc_list = l, use_list = u, lookup = t, pending = (eq # pe), proof_forest = pf, pf_labels = pfl, input = ip\<rparr> =
(let a = left eq; b = right eq in
  (if rep_of l a = rep_of l b
    then propagate \<lparr>cc_list = l, use_list = u, lookup = t, pending = pe, proof_forest = pf, pf_labels = pfl, input = ip\<rparr>
    else
      propagate (propagate_step l u t pe pf pfl ip a b eq)
))"
  by pat_completeness auto

lemma propagate_simps1[simp]:
  assumes "propagate_dom cc"
"pending cc = []"
shows "propagate cc = cc"
  using assms propagate.psimps propagate.pelims by fastforce

lemma propagate_simps2[simp]:
  assumes "propagate_dom \<lparr>cc_list = l, use_list = u, lookup = t, pending = (eq # pe), proof_forest = pf, pf_labels = pfl, input = ip\<rparr>"
"rep_of l (left eq) = rep_of l (right eq)"
shows "propagate
\<lparr>cc_list = l, use_list = u, lookup = t, pending = (eq # pe), proof_forest = pf, pf_labels = pfl, input = ip\<rparr>
 = propagate \<lparr>cc_list = l, use_list = u, lookup = t, pending = pe, proof_forest = pf, pf_labels = pfl, input = ip\<rparr>"
  using assms propagate.psimps unfolding Let_def by auto

lemma propagate_simps3[simp]:
  assumes "propagate_dom \<lparr>cc_list = l, use_list = u, lookup = t, pending = (eq # pe), proof_forest = pf, pf_labels = pfl, input = ip\<rparr>"
"rep_of l (left eq) \<noteq> rep_of l (right eq)"
shows "propagate
\<lparr>cc_list = l, use_list = u, lookup = t, pending = (eq # pe), proof_forest = pf, pf_labels = pfl, input = ip\<rparr>
 = propagate (propagate_step l u t pe pf pfl ip (left eq) (right eq) eq)"
  using assms propagate.psimps unfolding Let_def by auto

fun merge :: "congruence_closure \<Rightarrow> equation \<Rightarrow> congruence_closure"
  where
"merge \<lparr>cc_list = l, use_list = u, lookup = t, pending = pe, proof_forest = pf, pf_labels = pfl, input = ip\<rparr>
(a \<approx> b) =
  propagate
    \<lparr>cc_list = l, use_list = u, lookup = t, pending = One (a \<approx> b)#pe, proof_forest = pf, pf_labels = pfl, input = insert (a \<approx> b) ip\<rparr>"

| "merge \<lparr>cc_list = l, use_list = u, lookup = t, pending = pe, proof_forest = pf, pf_labels = pfl, input = ip\<rparr>
(F a\<^sub>1 a\<^sub>2 \<approx> a) =
(if (lookup_Some t l (F a\<^sub>1 a\<^sub>2 \<approx> a))
  then propagate \<lparr>cc_list = l, use_list = u, lookup = t,
            pending = link_to_lookup t l (F a\<^sub>1 a\<^sub>2 \<approx> a)#pe, proof_forest = pf, pf_labels = pfl, input = insert (F a\<^sub>1 a\<^sub>2 \<approx> a) ip\<rparr>
  else \<lparr>cc_list = l,
          use_list = (u[rep_of l a\<^sub>1 := (F a\<^sub>1 a\<^sub>2 \<approx> a)#(u ! rep_of l a\<^sub>1)])[rep_of l a\<^sub>2 := (F a\<^sub>1 a\<^sub>2 \<approx> a)#(u ! rep_of l a\<^sub>2)],
          lookup = update_lookup t l (F a\<^sub>1 a\<^sub>2 \<approx> a),
          pending = pe, proof_forest = pf, pf_labels = pfl, input = insert (F a\<^sub>1 a\<^sub>2 \<approx> a) ip\<rparr>
)"

text \<open>The input must be a valid index (a < nr_vars cc \<and> b < nr_vars cc)\<close>
fun are_congruent :: "congruence_closure \<Rightarrow> equation \<Rightarrow> bool"
  where
"are_congruent \<lparr>cc_list = l, use_list = u, lookup = t, pending = pe, proof_forest = pf, pf_labels = pfl, input = ip\<rparr> (a \<approx> b) =
    (rep_of l a = rep_of l b)"
| "are_congruent \<lparr>cc_list = l, use_list = u, lookup = t, pending = pe, proof_forest = pf, pf_labels = pfl, input = ip\<rparr> (F a\<^sub>1 a\<^sub>2 \<approx> a) =
    (case lookup_entry t l a\<^sub>1 a\<^sub>2 of
      Some (F b\<^sub>1 b\<^sub>2 \<approx> b) \<Rightarrow> (rep_of l a = rep_of l b)
    | None \<Rightarrow> False
)"

lemma are_congruent_simp:
"are_congruent cc (a \<approx> b) = (rep_of (cc_list cc) a = rep_of (cc_list cc) b)"
  by (metis are_congruent.simps(1) congruence_closure.surjective old.unit.exhaust)

text \<open>For the initialisation of the congruence closure algorithm.\<close>
abbreviation
"initial_cc n \<equiv> \<lparr>cc_list = [0..<n], use_list = replicate n [], lookup = replicate n (replicate n None),
                  pending = [], proof_forest = [0..<n], pf_labels = replicate n None, input = {}\<rparr>"

end


section {* Verification Component Based on KAT *}

theory VC_KAT
imports "../P2S2R"
        "$AFP/KAT_and_DRA/SingleSorted/PHL_KAT"
        "$AFP/KAT_and_DRA/SingleSorted/KAT_Models"

begin

text{* This first part changes some of the facts from the AFP KAT theories. It should be added to KAT in the next AFP version.
Currently these facts provide an interface between the KAT theories and the verification component. *}

no_notation if_then_else ("if _ then _ else _ fi" [64,64,64] 63)
no_notation while ("while _ do _ od" [64,64] 63)
no_notation Archimedean_Field.ceiling ("\<lceil>_\<rceil>")

notation relcomp (infixl ";" 70)
notation p2r ("\<lceil>_\<rceil>")

context kat
begin

subsection {* Definitions of Hoare Triple *}

definition H :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" where
  "H p x q \<longleftrightarrow> t p \<cdot> x \<le> x \<cdot> t q"

lemma H_var1: "H p x q \<longleftrightarrow> t p \<cdot> x \<cdot> n q = 0"
  by (metis H_def n_kat_3 t_n_closed)

lemma H_var2: "H p x q \<longleftrightarrow> t p \<cdot> x = t p \<cdot> x \<cdot> t q"
  by (simp add: H_def n_kat_2)

subsection {* Syntax for Conditionals and Loops *}

definition ifthenelse :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" ("if _ then _ else _ fi" [64,64,64] 63) where
  "if p then x else y fi = (t p \<cdot> x + n p \<cdot> y)"

definition while :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" ("while _ do _ od" [64,64] 63) where
  "while b do x od = (t b \<cdot> x)\<^sup>\<star> \<cdot> n b"

definition while_inv :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" ("while _ inv _ do _ od" [64,64,64] 63) where
  "while p inv i do x od = while p do x od"

subsection {* Inference Rules of Propositional Hoare Logic *}

lemma H_skip:  "H p 1 p"
  by (simp add: H_def)

lemma H_cons_1: "t p \<le> t p' \<Longrightarrow> H p' x q \<Longrightarrow> H p x q"
  using H_def phl_cons1 by blast

lemma H_cons_2: "t q' \<le> t q \<Longrightarrow> H p x q' \<Longrightarrow> H p x q"
  using H_def phl_cons2 by blast

lemma H_cons: "t p \<le> t p' \<Longrightarrow> t q' \<le> t q \<Longrightarrow> H p' x q' \<Longrightarrow> H p x q"
  by (simp add: H_cons_1 H_cons_2)

lemma H_seq_swap: "H p x r \<Longrightarrow> H r y q \<Longrightarrow> H p (x \<cdot> y) q"
  by (simp add: H_def phl_seq)

lemma H_seq: "H r y q \<Longrightarrow> H p x r \<Longrightarrow> H p (x \<cdot> y) q"
  by (simp add: H_seq_swap)

lemma H_exp1: "H (t p \<cdot> t r) x q \<Longrightarrow> H p (t r \<cdot> x) q"
  using H_def n_de_morgan_var2 phl.ht_at_phl_export1 by auto

lemma H_exp2: "H p x q \<Longrightarrow> H p (x \<cdot> t r) (t q \<cdot> t r)"
  by (metis H_def phl.ht_at_phl_export2 test_mult)

lemma H_cond_iff: "H p (if r then x else y fi) q \<longleftrightarrow> H (t p \<cdot> t r) x q \<and> H (t p \<cdot> n r) y q"
proof -
  have "H p (if r then x else y fi) q \<longleftrightarrow> t p \<cdot> (t r \<cdot> x + n r \<cdot> y) \<cdot> n q = 0"
    by (simp add: H_var1 ifthenelse_def)
  also have "... \<longleftrightarrow> t p \<cdot> t r \<cdot> x \<cdot> n q + t p \<cdot> n r \<cdot> y \<cdot> n q = 0"
    by (simp add: distrib_left mult_assoc)
  also have "... \<longleftrightarrow> t p \<cdot> t r \<cdot> x \<cdot> n q = 0 \<and> t p \<cdot> n r \<cdot> y \<cdot> n q = 0"
    by (metis add_0_left no_trivial_inverse)
  finally show ?thesis
    by (metis H_var1 test_mult)
qed

lemma H_cond: "H (t p \<cdot> t r) x q \<Longrightarrow> H (t p \<cdot> n r) y q \<Longrightarrow> H p (if r then x else y fi) q"
  by (simp add: H_cond_iff)

lemma H_loop: "H (t p \<cdot> t r) x p \<Longrightarrow> H p (while r do x od) (t p \<cdot> n r)"
proof -
  assume a1: "H (t p \<cdot> t r) x p"
  have "t (t p \<cdot> n r) = n r \<cdot> t p \<cdot> n r"
    using n_preserve test_mult by presburger
  then show ?thesis
    using a1 H_def H_exp1 conway.phl.it_simr phl_export2 while_def by auto
qed

lemma H_while_inv: "t p \<le> t i \<Longrightarrow> t i \<cdot> n r \<le> t q \<Longrightarrow> H (t i \<cdot> t r) x i \<Longrightarrow> H p (while r inv i do x od) q"
  by (metis H_cons H_loop test_mult while_inv_def)

text {* Finally we prove a frame rule. *}

lemma H_frame: "H p x p \<Longrightarrow> H q x r \<Longrightarrow> H (t p \<cdot> t q) x (t p \<cdot> t r)"
proof -
  assume "H p x p" and a: "H q x r"
  hence b: "t p \<cdot> x \<le> x \<cdot> t p" and "t q \<cdot> x \<le> x \<cdot> t r"
    using H_def apply blast using H_def a by blast
  hence "t p \<cdot> t q \<cdot> x \<le> t p \<cdot> x \<cdot> t r"
    by (simp add: mult_assoc mult_isol)
  also have "... \<le> x \<cdot> t p \<cdot> t r"
    by (simp add: b mult_isor)
  finally show ?thesis
    by (metis H_def mult_assoc test_mult)
qed

end

subsection {* Store and Assignment *}

text {* The proper verification component starts here. *}

type_synonym 'a store = "string  \<Rightarrow> 'a"

lemma t_p2r [simp]: "rel_dioid_tests.t \<lceil>P\<rceil> = \<lceil>P\<rceil>"
  by (auto simp: p2r_def)

lemma impl_prop [simp]: "\<lceil>P\<rceil> \<subseteq> \<lceil>Q\<rceil> \<longleftrightarrow> (\<forall>s. P s \<longrightarrow>  Q s)"
  by (auto simp: p2r_def)

lemma Id_simp [simp]: "Id \<inter> (- Id \<union> X) = Id \<inter> X"
  by auto

lemma Id_p2r [simp]: "Id \<inter> \<lceil>P\<rceil> = \<lceil>P\<rceil>"
  by (auto simp: Id_def p2r_def)

lemma Id_p2r_simp [simp]: "Id \<inter> (- Id \<union> \<lceil>P\<rceil>) = \<lceil>P\<rceil>"
  by simp

text {* Next we derive the assignment command and assignment rules.  *}

definition gets :: "string \<Rightarrow> ('a store \<Rightarrow> 'a) \<Rightarrow> 'a store rel" ("_ ::= _" [70, 65] 61) where
  "v ::= e = {(s,s (v := e s)) |s. True}"

lemma H_assign_prop: "\<lceil>\<lambda>s. P (s (v := e s))\<rceil> ; (v ::= e) = (v ::= e) ; \<lceil>P\<rceil>"
  by (auto simp: p2r_def gets_def)

lemma H_assign: "rel_kat.H \<lceil>\<lambda>s. P (s (v := e s))\<rceil> (v ::= e) \<lceil>P\<rceil>"
  by (auto simp add: rel_kat.H_def gets_def p2r_def)

lemma H_assign_var: "(\<forall>s. P s \<longrightarrow> Q (s (v := e s))) \<Longrightarrow> rel_kat.H \<lceil>P\<rceil> (v ::= e) \<lceil>Q\<rceil>"
  by (auto simp: p2r_def gets_def rel_kat.H_def)

lemma H_assign_iff [simp]: "rel_kat.H \<lceil>P\<rceil> (v ::= e) \<lceil>Q\<rceil> \<longleftrightarrow> (\<forall>s. P s \<longrightarrow> Q (s (v := e s)))"
  by (auto simp: p2r_def gets_def rel_kat.H_def)

subsection {* Simplified Hoare Rules *}

lemma sH_cons_1: "\<forall>s. P s \<longrightarrow> P' s \<Longrightarrow> rel_kat.H \<lceil>P'\<rceil> X \<lceil>Q\<rceil> \<Longrightarrow> rel_kat.H \<lceil>P\<rceil> X \<lceil>Q\<rceil>"
  by (rule rel_kat.H_cons_1, auto simp only: p2r_def)

lemma sH_cons_2: "\<forall>s. Q' s \<longrightarrow> Q s \<Longrightarrow> rel_kat.H \<lceil>P\<rceil> X \<lceil>Q'\<rceil> \<Longrightarrow> rel_kat.H \<lceil>P\<rceil> X \<lceil>Q\<rceil>"
  by (rule rel_kat.H_cons_2, auto simp only: p2r_def)

lemma sH_cons: "\<forall>s. P s \<longrightarrow> P' s \<Longrightarrow> \<forall>s. Q' s \<longrightarrow> Q s \<Longrightarrow> rel_kat.H \<lceil>P'\<rceil> X \<lceil>Q'\<rceil> \<Longrightarrow> rel_kat.H \<lceil>P\<rceil> X \<lceil>Q\<rceil>"
  by (simp add: sH_cons_1 sH_cons_2)

lemma sH_cond: "rel_kat.H \<lceil>P \<sqinter> T\<rceil> X \<lceil>Q\<rceil> \<Longrightarrow> rel_kat.H \<lceil>P \<sqinter> - T\<rceil> Y \<lceil>Q\<rceil>  \<Longrightarrow> rel_kat.H \<lceil>P\<rceil> (rel_kat.ifthenelse \<lceil>T\<rceil> X Y) \<lceil>Q\<rceil>"
  by (rule rel_kat.H_cond, auto simp add: rel_kat.H_def p2r_def, blast+)

lemma sH_cond_iff: "rel_kat.H \<lceil>P\<rceil> (rel_kat.ifthenelse \<lceil>T\<rceil> X Y) \<lceil>Q\<rceil> \<longleftrightarrow> (rel_kat.H \<lceil>P \<sqinter> T\<rceil> X \<lceil>Q\<rceil> \<and> rel_kat.H \<lceil>P \<sqinter> - T\<rceil> Y \<lceil>Q\<rceil>)"
  by (simp add: rel_kat.H_cond_iff)

lemma sH_while_inv: "\<forall>s. P s \<longrightarrow> I s \<Longrightarrow> \<forall>s. I s \<and> \<not> R s \<longrightarrow> Q s \<Longrightarrow> rel_kat.H \<lceil>I \<sqinter> R\<rceil> X \<lceil>I\<rceil>
                     \<Longrightarrow> rel_kat.H \<lceil>P\<rceil> (rel_kat.while_inv \<lceil>R\<rceil> \<lceil>I\<rceil> X) \<lceil>Q\<rceil>"
  by (rule rel_kat.H_while_inv, auto simp: p2r_def rel_kat.H_def, fastforce)

lemma sH_H: "rel_kat.H \<lceil>P\<rceil> X \<lceil>Q\<rceil> \<longleftrightarrow> (\<forall>s s'. P s \<longrightarrow> (s,s') \<in> X \<longrightarrow> Q s')"
  by (simp add: rel_kat.H_def, auto simp add: p2r_def)

text {* Finally we provide additional syntax for specifications and commands. *}

abbreviation H_sugar :: "'a pred \<Rightarrow> 'a rel \<Rightarrow> 'a pred \<Rightarrow> bool" ("PRE _ _ POST _" [64,64,64] 63) where
  "PRE P X POST Q \<equiv> rel_kat.H \<lceil>P\<rceil> X \<lceil>Q\<rceil>"

abbreviation if_then_else_sugar :: "'a pred \<Rightarrow> 'a rel \<Rightarrow> 'a rel \<Rightarrow> 'a rel" ("IF _ THEN _ ELSE _ FI" [64,64,64] 63) where
  "IF P THEN X ELSE Y FI \<equiv> rel_kat.ifthenelse \<lceil>P\<rceil> X Y"

abbreviation while_inv_sugar :: "'a pred \<Rightarrow> 'a pred \<Rightarrow> 'a rel \<Rightarrow> 'a rel" ("WHILE _ INV _ DO _ OD" [64,64,64] 63) where
  "WHILE P INV I DO X OD \<equiv> rel_kat.while_inv \<lceil>P\<rceil> \<lceil>I\<rceil> X"

lemma H_cond_iff2[simp]: "PRE p (IF r THEN x ELSE y FI) POST q \<longleftrightarrow> (PRE (p \<sqinter> r) x POST q) \<and> (PRE (p \<sqinter> - r) y POST q)"
  by (simp add: rel_kat.H_cond_iff)

end