(*
    Author:   Salomon Sickert
    Author:   Benedikt Seidl
    Author:   Alexander Schimpf (original entry: CAVA/LTL_Rewrite.thy)
    License:  BSD
*)

section \<open>Rewrite Rules for LTL Simplification\<close>

theory Rewriting
imports
  LTL "HOL-Library.Extended_Nat"
begin

text \<open>This theory provides rewrite rules for the simplification of LTL formulas. It supports:
  \begin{itemize}
    \item Constants Removal
    \item @{const Next_ltln}-Normalisation
    \item Modal Simplification (based on pure eventual, pure universal, or suspendable formulas)
    \item Syntactic Implication Checking
  \end{itemize}
  It reuses parts of LTL\_Rewrite.thy (CAVA, LTL\_TO\_GBA). Furthermore, some rules were taken from
  \cite{DBLP:conf/cav/SomenziB00} and \cite{DBLP:conf/tacas/BabiakKRS12}. All functions are defined for @{type ltln}.\<close>

subsection \<open>Constant Eliminating Constructors\<close>

definition mk_and
where
  "mk_and x y \<equiv> case x of false\<^sub>n \<Rightarrow> false\<^sub>n | true\<^sub>n \<Rightarrow> y | _ \<Rightarrow> (case y of false\<^sub>n \<Rightarrow> false\<^sub>n | true\<^sub>n \<Rightarrow> x | _ \<Rightarrow> x and\<^sub>n y)"

definition mk_or
where
  "mk_or x y \<equiv> case x of false\<^sub>n \<Rightarrow> y | true\<^sub>n \<Rightarrow> true\<^sub>n | _ \<Rightarrow> (case y of true\<^sub>n \<Rightarrow> true\<^sub>n | false\<^sub>n \<Rightarrow> x | _ \<Rightarrow> x or\<^sub>n y)"

fun remove_strong_ops
where
  "remove_strong_ops (x U\<^sub>n y) = remove_strong_ops y"
| "remove_strong_ops (x M\<^sub>n y) = x and\<^sub>n y"
| "remove_strong_ops (x or\<^sub>n y) = remove_strong_ops x or\<^sub>n remove_strong_ops y"
| "remove_strong_ops x = x"

fun remove_weak_ops
where
  "remove_weak_ops (x R\<^sub>n y) = remove_weak_ops y"
| "remove_weak_ops (x W\<^sub>n y) = x or\<^sub>n y"
| "remove_weak_ops (x and\<^sub>n y) = remove_weak_ops x and\<^sub>n remove_weak_ops y"
| "remove_weak_ops x = x"

definition mk_finally
where
  "mk_finally x \<equiv> case x of true\<^sub>n \<Rightarrow> true\<^sub>n | false\<^sub>n \<Rightarrow> false\<^sub>n | _ \<Rightarrow> F\<^sub>n (remove_strong_ops x)"

definition mk_globally
where
  "mk_globally x \<equiv> case x of true\<^sub>n \<Rightarrow> true\<^sub>n | false\<^sub>n \<Rightarrow> false\<^sub>n | _ \<Rightarrow> G\<^sub>n (remove_weak_ops x)"

definition mk_until
where
  "mk_until x y \<equiv> case x of false\<^sub>n \<Rightarrow> y
    | true\<^sub>n \<Rightarrow> mk_finally y
    | _ \<Rightarrow> (case y of true\<^sub>n \<Rightarrow> true\<^sub>n | false\<^sub>n \<Rightarrow> false\<^sub>n | _ \<Rightarrow> x U\<^sub>n y)"

definition mk_release
where
  "mk_release x y \<equiv> case x of true\<^sub>n \<Rightarrow> y
    | false\<^sub>n \<Rightarrow> mk_globally y
    | _ \<Rightarrow> (case y of true\<^sub>n \<Rightarrow> true\<^sub>n | false\<^sub>n \<Rightarrow> false\<^sub>n | _ \<Rightarrow> x R\<^sub>n y)"

definition mk_weak_until
where
  "mk_weak_until x y \<equiv> case y of true\<^sub>n \<Rightarrow> true\<^sub>n
    | false\<^sub>n \<Rightarrow> mk_globally x
    | _ \<Rightarrow> (case x of true\<^sub>n \<Rightarrow> true\<^sub>n | false\<^sub>n \<Rightarrow> y | _ \<Rightarrow> x W\<^sub>n y)"

definition mk_strong_release
where
  "mk_strong_release x y \<equiv> case y of false\<^sub>n \<Rightarrow> false\<^sub>n
    | true\<^sub>n \<Rightarrow> mk_finally x
    | _ \<Rightarrow> (case x of true\<^sub>n \<Rightarrow> y | false\<^sub>n \<Rightarrow> false\<^sub>n | _ \<Rightarrow> x M\<^sub>n y)"

definition mk_next
where
  "mk_next x \<equiv> case x of true\<^sub>n \<Rightarrow> true\<^sub>n | false\<^sub>n \<Rightarrow> false\<^sub>n | _ \<Rightarrow> X\<^sub>n x"

definition mk_next_pow ("X\<^sub>n''")
where
  "mk_next_pow n x \<equiv> case x of true\<^sub>n \<Rightarrow> true\<^sub>n | false\<^sub>n \<Rightarrow> false\<^sub>n | _ \<Rightarrow> (Next_ltln ^^ n) x"

lemma mk_and_semantics [simp]:
  "w \<Turnstile>\<^sub>n mk_and x y \<longleftrightarrow> w \<Turnstile>\<^sub>n x and\<^sub>n y"
  unfolding mk_and_def by (cases x; cases y; simp)

lemma mk_or_semantics [simp]:
  "w \<Turnstile>\<^sub>n mk_or x y \<longleftrightarrow> w \<Turnstile>\<^sub>n x or\<^sub>n y"
  unfolding mk_or_def by (cases x; cases y; simp)

lemma remove_strong_ops_sound [simp]:
  "w \<Turnstile>\<^sub>n F\<^sub>n (remove_strong_ops y) \<longleftrightarrow> w \<Turnstile>\<^sub>n F\<^sub>n y"
  by (induction y arbitrary: w) (auto; force)+

lemma remove_weak_ops_sound [simp]:
  "w \<Turnstile>\<^sub>n G\<^sub>n (remove_weak_ops y) \<longleftrightarrow> w \<Turnstile>\<^sub>n G\<^sub>n y"
  by (induction y arbitrary: w) (auto; force)+

lemma mk_finally_semantics [simp]:
  "w \<Turnstile>\<^sub>n mk_finally x \<longleftrightarrow> w \<Turnstile>\<^sub>n F\<^sub>n x"
  by (simp add: mk_finally_def del: semantics_ltln.simps(8,9) remove_strong_ops.simps split: ltln.splits)

lemma mk_globally_semantics [simp]:
  "w \<Turnstile>\<^sub>n mk_globally x \<longleftrightarrow> w \<Turnstile>\<^sub>n G\<^sub>n x"
  by (simp add: mk_globally_def del: semantics_ltln.simps(8,9) remove_weak_ops.simps split: ltln.splits)

lemma mk_until_semantics [simp]:
  "w \<Turnstile>\<^sub>n mk_until x y \<longleftrightarrow> w \<Turnstile>\<^sub>n x U\<^sub>n y"
proof (cases x)
  case (True_ltln)
    show ?thesis
      unfolding True_ltln mk_until_def
      by (cases y) auto
next
  case (False_ltln)
    thus ?thesis
      by (force simp: mk_until_def)
qed (cases y; force simp: mk_until_def)+

lemma mk_release_semantics [simp]:
  "w \<Turnstile>\<^sub>n mk_release x y \<longleftrightarrow> w \<Turnstile>\<^sub>n x R\<^sub>n y"
proof (cases x)
  case (False_ltln)
    thus ?thesis
      unfolding False_ltln mk_release_def
      by (cases y) auto
next
  case (True_ltln)
    thus ?thesis
      by (force simp: mk_release_def)
qed (cases y; force simp: mk_release_def)+

lemma mk_weak_until_semantics [simp]:
  "w \<Turnstile>\<^sub>n mk_weak_until x y \<longleftrightarrow> w \<Turnstile>\<^sub>n x W\<^sub>n y"
proof (cases y)
  case (False_ltln)
    thus ?thesis
      unfolding False_ltln mk_weak_until_def
      by (cases x) auto
next
  case (True_ltln)
    thus ?thesis
      by (force simp: mk_weak_until_def)
qed (cases x; force simp: mk_weak_until_def)+

lemma mk_strong_release_semantics [simp]:
  "w \<Turnstile>\<^sub>n mk_strong_release x y \<longleftrightarrow> w \<Turnstile>\<^sub>n x M\<^sub>n y"
proof (cases y)
  case (True_ltln)
    show ?thesis
      unfolding True_ltln mk_strong_release_def
      by (cases x) auto
next
  case (False_ltln)
    thus ?thesis
      by (force simp: mk_strong_release_def)
qed (cases x; force simp: mk_strong_release_def)+

lemma mk_next_semantics [simp]:
  "w \<Turnstile>\<^sub>n mk_next x \<longleftrightarrow> w \<Turnstile>\<^sub>n X\<^sub>n x"
  unfolding mk_next_def by (cases x; auto)

lemma mk_next_pow_semantics [simp]:
  "w \<Turnstile>\<^sub>n mk_next_pow i x \<longleftrightarrow> suffix i w \<Turnstile>\<^sub>n x"
  by (induction i arbitrary: w; cases x)
     (auto simp: mk_next_pow_def)

lemma mk_next_pow_simp [simp, code_unfold]:
  "mk_next_pow 0 x = x"
  "mk_next_pow 1 x = mk_next x"
  by (cases x; simp add: mk_next_pow_def mk_next_def)+

subsection \<open>Constant Propagation\<close>

fun is_constant :: "'a ltln \<Rightarrow> bool"
where
  "is_constant true\<^sub>n = True"
| "is_constant false\<^sub>n = True"
| "is_constant _ = False"

lemma is_constant_constructorsI:
  "is_constant x \<Longrightarrow> is_constant y \<Longrightarrow> is_constant (mk_and x y)"
  "\<not>is_constant x \<Longrightarrow> \<not>is_constant y \<Longrightarrow> \<not>is_constant (mk_and x y)"
  "is_constant x \<Longrightarrow> is_constant y \<Longrightarrow> is_constant (mk_or x y)"
  "\<not>is_constant x \<Longrightarrow> \<not>is_constant y \<Longrightarrow> \<not>is_constant (mk_or x y)"
  "is_constant x \<Longrightarrow>  is_constant (mk_finally x)"
  "\<not>is_constant x \<Longrightarrow>  \<not>is_constant (mk_finally x)"
  "is_constant x \<Longrightarrow> is_constant (mk_globally x)"
  "\<not>is_constant x \<Longrightarrow>  \<not>is_constant (mk_globally x)"
  "is_constant x \<Longrightarrow> is_constant (mk_until y x)"
  "\<not>is_constant x \<Longrightarrow> \<not>is_constant (mk_until y x)"
  "is_constant x \<Longrightarrow> is_constant (mk_release y x)"
  "\<not>is_constant x \<Longrightarrow> \<not>is_constant (mk_release y x)"
  "is_constant x \<Longrightarrow> is_constant y \<Longrightarrow> is_constant (mk_weak_until x y)"
  "\<not>is_constant x \<Longrightarrow> \<not>is_constant y \<Longrightarrow> \<not>is_constant (mk_weak_until x y)"
  "is_constant x \<Longrightarrow> is_constant y \<Longrightarrow> is_constant (mk_strong_release x y)"
  "\<not>is_constant x \<Longrightarrow> \<not>is_constant y \<Longrightarrow> \<not>is_constant (mk_strong_release x y)"
  "is_constant x \<Longrightarrow> is_constant (mk_next x)"
  "\<not>is_constant x \<Longrightarrow> \<not>is_constant (mk_next x)"
  "is_constant x \<Longrightarrow> is_constant (mk_next_pow n x)"
  by (cases x; cases y; simp add: mk_and_def mk_or_def mk_finally_def mk_globally_def mk_until_def mk_release_def mk_weak_until_def mk_strong_release_def mk_next_def mk_next_pow_def)+

lemma is_constant_constructors_simps:
  "mk_next_pow n x = false\<^sub>n \<longleftrightarrow> x = false\<^sub>n"
  "mk_next_pow n x = true\<^sub>n \<longleftrightarrow> x = true\<^sub>n"
  "is_constant (mk_next_pow n x) \<longleftrightarrow> is_constant x"
  by (induction n) (cases x; simp add: mk_next_pow_def)+

lemma is_constant_constructors_simps2:
  "is_constant (mk_and x y) \<longleftrightarrow> (x = true\<^sub>n \<and> y = true\<^sub>n \<or> x = false\<^sub>n \<or> y = false\<^sub>n)"
  "is_constant (mk_or x y) \<longleftrightarrow> (x = false\<^sub>n \<and> y = false\<^sub>n \<or> x = true\<^sub>n \<or> y = true\<^sub>n)"
  "is_constant (mk_finally x) \<longleftrightarrow> is_constant x"
  "is_constant (mk_globally x) \<longleftrightarrow> is_constant x"
  "is_constant (mk_until y x) \<longleftrightarrow> is_constant x"
  "is_constant (mk_release y x) \<longleftrightarrow> is_constant x"
  "is_constant (mk_next x) \<longleftrightarrow> is_constant x"
  by ((cases x; cases y; simp add: mk_and_def),
      (cases x; cases y; simp add: mk_or_def),
      (meson is_constant_constructorsI)+)

lemma is_constant_constructors_simps3:
  "is_constant (mk_weak_until x y) \<longleftrightarrow> (x = false\<^sub>n \<and> y = false\<^sub>n \<or> x = true\<^sub>n \<or> y = true\<^sub>n)"
  "is_constant (mk_strong_release x y) \<longleftrightarrow> (x = true\<^sub>n \<and> y = true\<^sub>n \<or> x = false\<^sub>n \<or> y = false\<^sub>n)"
  by (cases x; cases y; simp add: mk_weak_until_def mk_strong_release_def is_constant_constructors_simps2)+

lemma is_constant_semantics:
  "is_constant \<phi> \<Longrightarrow> ((\<forall>w. w \<Turnstile>\<^sub>n \<phi>) \<or> \<not>(\<exists>w. w \<Turnstile>\<^sub>n \<phi>))"
  by (cases \<phi>) auto

lemma until_constant_simp:
  "is_constant \<psi> \<Longrightarrow> w \<Turnstile>\<^sub>n \<phi> U\<^sub>n \<psi> \<longleftrightarrow> w \<Turnstile>\<^sub>n \<psi>"
  by (cases \<psi>) auto

lemma release_constant_simp:
  "is_constant \<psi> \<Longrightarrow> w \<Turnstile>\<^sub>n \<phi> R\<^sub>n \<psi> \<longleftrightarrow> w \<Turnstile>\<^sub>n \<psi>"
  by (cases \<psi>) auto

lemma mk_next_pow_dist:
  "mk_next_pow (i + j) \<phi> = mk_next_pow i (mk_next_pow j \<phi>)"
  by (cases j; simp) (cases \<phi>; simp add: mk_next_pow_def funpow_add; simp add: funpow_swap1)

lemma mk_next_pow_until:
  "suffix (min i j) w \<Turnstile>\<^sub>n (mk_next_pow (i - j) \<phi>) U\<^sub>n (mk_next_pow (j - i) \<psi>) \<longleftrightarrow> w \<Turnstile>\<^sub>n (mk_next_pow i \<phi>) U\<^sub>n (mk_next_pow j \<psi>)"
  by (simp add: mk_next_pow_dist min_def add.commute)

lemma mk_next_pow_release:
  "suffix (min i j) w \<Turnstile>\<^sub>n (mk_next_pow (i - j) \<phi>) R\<^sub>n (mk_next_pow (j - i) \<psi>) \<longleftrightarrow> w \<Turnstile>\<^sub>n (mk_next_pow i \<phi>) R\<^sub>n (mk_next_pow j \<psi>)"
  by (simp add: mk_next_pow_dist min_def add.commute)

subsection \<open>X-Normalisation\<close>

text \<open>The following rewrite functions pulls the X-operator up in the syntax tree. This preprocessing
  step enables the removal of X-operators in front of suspendable formulas. Furthermore constants are
  removed as far as possible.\<close>

fun the_enat_0 :: "enat \<Rightarrow> nat"
where
  "the_enat_0 i = i"
| "the_enat_0 \<infinity> = 0"

lemma the_enat_0_simp [simp]:
  "the_enat_0 0 = 0"
  "the_enat_0 1 = 1"
  by (simp add: zero_enat_def one_enat_def)+

fun combine :: "('a ltln \<Rightarrow> 'a ltln \<Rightarrow> 'a ltln) \<Rightarrow> ('a ltln * enat) \<Rightarrow> ('a ltln * enat) \<Rightarrow> ('a ltln * enat)"
where
  "combine binop (\<phi>, i) (\<psi>, j) = (
    let
      \<chi> = binop (mk_next_pow (the_enat_0 (i - j)) \<phi>) (mk_next_pow (the_enat_0 (j - i)) \<psi>)
    in
      (\<chi>, if is_constant \<chi> then \<infinity> else min i j))"

lemma fst_combine:
  "fst (combine binop (\<phi>, i) (\<psi>, j)) = binop (mk_next_pow (the_enat_0 (i - j)) \<phi>) (mk_next_pow (the_enat_0 (j - i)) \<psi>)"
  unfolding combine.simps by (meson fstI)

abbreviation to_ltln :: "('a ltln * enat) \<Rightarrow> 'a ltln"
where
  "to_ltln x \<equiv> mk_next_pow (the_enat_0 (snd x)) (fst x)"

fun rewrite_X_enat :: "'a ltln \<Rightarrow> ('a ltln * enat)"
where
  "rewrite_X_enat true\<^sub>n = (true\<^sub>n, \<infinity>)"
| "rewrite_X_enat false\<^sub>n = (false\<^sub>n, \<infinity>)"
| "rewrite_X_enat prop\<^sub>n(a) = (prop\<^sub>n(a), 0)"
| "rewrite_X_enat nprop\<^sub>n(a) = (nprop\<^sub>n(a), 0)"
| "rewrite_X_enat (\<phi> and\<^sub>n \<psi>) = combine mk_and (rewrite_X_enat \<phi>) (rewrite_X_enat \<psi>)"
| "rewrite_X_enat (\<phi> or\<^sub>n \<psi>) = combine mk_or (rewrite_X_enat \<phi>) (rewrite_X_enat \<psi>)"
| "rewrite_X_enat (\<phi> U\<^sub>n \<psi>) = combine mk_until (rewrite_X_enat \<phi>) (rewrite_X_enat \<psi>)"
| "rewrite_X_enat (\<phi> R\<^sub>n \<psi>) = combine mk_release (rewrite_X_enat \<phi>) (rewrite_X_enat \<psi>)"
| "rewrite_X_enat (\<phi> W\<^sub>n \<psi>) = combine mk_weak_until (rewrite_X_enat \<phi>) (rewrite_X_enat \<psi>)"
| "rewrite_X_enat (\<phi> M\<^sub>n \<psi>) = combine mk_strong_release (rewrite_X_enat \<phi>) (rewrite_X_enat \<psi>)"
| "rewrite_X_enat (X\<^sub>n \<phi>) = (\<lambda>(\<phi>, n). (\<phi>, eSuc n)) (rewrite_X_enat \<phi>)"

definition
  "rewrite_X \<phi> = to_ltln (rewrite_X_enat \<phi>)"

lemma combine_infinity_invariant:
  assumes "i = \<infinity> \<longleftrightarrow> is_constant x"
  assumes "j = \<infinity> \<longleftrightarrow> is_constant y"
  shows "combine mk_and (x, i) (y, j) = (z, k) \<Longrightarrow> (k = \<infinity> \<longleftrightarrow> is_constant z)"
    and "combine mk_or (x, i) (y, j) = (z, k) \<Longrightarrow> (k = \<infinity> \<longleftrightarrow> is_constant z)"
    and "combine mk_until (x, i) (y, j) = (z, k) \<Longrightarrow> (k = \<infinity> \<longleftrightarrow> is_constant z)"
    and "combine mk_release (x, i) (y, j) = (z, k) \<Longrightarrow> (k = \<infinity> \<longleftrightarrow> is_constant z)"
    and "combine mk_weak_until (x, i) (y, j) = (z, k) \<Longrightarrow> (k = \<infinity> \<longleftrightarrow> is_constant z)"
    and "combine mk_strong_release (x, i) (y, j) = (z, k) \<Longrightarrow> (k = \<infinity> \<longleftrightarrow> is_constant z)"
  by (cases i; cases j; simp add: assms Let_def; force intro: is_constant_constructorsI)+

lemma combine_and_or_semantics:
  assumes "i = \<infinity> \<longleftrightarrow> is_constant \<phi>"
  assumes "j = \<infinity> \<longleftrightarrow> is_constant \<psi>"
  shows "w \<Turnstile>\<^sub>n to_ltln (combine mk_and (\<phi>, i) (\<psi>, j)) \<longleftrightarrow> w \<Turnstile>\<^sub>n to_ltln (\<phi>, i) and\<^sub>n to_ltln (\<psi>, j)"
    and "w \<Turnstile>\<^sub>n to_ltln (combine mk_or (\<phi>, i) (\<psi>, j)) \<longleftrightarrow> w \<Turnstile>\<^sub>n to_ltln (\<phi>, i) or\<^sub>n to_ltln (\<psi>, j)"
  by ((cases i; cases j; simp add: min_def is_constant_constructors_simps is_constant_constructors_simps2 assms),
      (cases \<psi>; insert assms; auto),
      (cases \<phi>; insert assms; auto),
      (blast elim!: is_constant.elims))+

lemma combine_until_release_semantics:
  assumes "i = \<infinity> \<longleftrightarrow> is_constant \<phi>"
  assumes "j = \<infinity> \<longleftrightarrow> is_constant \<psi>"
  shows "w \<Turnstile>\<^sub>n to_ltln (combine mk_until (\<phi>, i) (\<psi>, j)) \<longleftrightarrow> w \<Turnstile>\<^sub>n to_ltln (\<phi>, i) U\<^sub>n to_ltln (\<psi>, j)"
    and "w \<Turnstile>\<^sub>n to_ltln (combine mk_release (\<phi>, i) (\<psi>, j)) \<longleftrightarrow> w \<Turnstile>\<^sub>n to_ltln (\<phi>, i) R\<^sub>n to_ltln (\<psi>, j)"
  by ((cases i; cases j; simp add: is_constant_constructors_simps is_constant_constructors_simps2
       until_constant_simp release_constant_simp mk_next_pow_until mk_next_pow_release del: semantics_ltln.simps),
      (blast dest: is_constant_semantics),
      (cases \<psi>; simp add: assms),
      (cases \<phi>; insert assms; auto simp: add.commute))+

(* TODO this proof is a bit slow and could be optimized *)
lemma combine_weak_until_strong_release_semantics:
  assumes "i = \<infinity> \<longleftrightarrow> is_constant \<phi>"
  assumes "j = \<infinity> \<longleftrightarrow> is_constant \<psi>"
  shows "w \<Turnstile>\<^sub>n to_ltln (combine mk_weak_until (\<phi>, i) (\<psi>, j)) \<longleftrightarrow> w \<Turnstile>\<^sub>n to_ltln (\<phi>, i) W\<^sub>n to_ltln (\<psi>, j)"
    and "w \<Turnstile>\<^sub>n to_ltln (combine mk_strong_release (\<phi>, i) (\<psi>, j)) \<longleftrightarrow> w \<Turnstile>\<^sub>n to_ltln (\<phi>, i) M\<^sub>n to_ltln (\<psi>, j)"
  by ((cases i; cases j; simp add: min_def is_constant_constructors_simps is_constant_constructors_simps3 del: semantics_ltln.simps),
      (cases \<phi>; simp add: assms),
      (cases \<psi>; insert assms; auto simp: add.commute))+

lemma rewrite_X_enat_infinity_invariant:
  "snd (rewrite_X_enat \<phi>) = \<infinity> \<longleftrightarrow> is_constant (fst (rewrite_X_enat \<phi>))"
proof (induction \<phi>)
  case (And_ltln \<phi> \<psi>)
    thus ?case
      by (simp add: combine_infinity_invariant[OF And_ltln(1,2), unfolded prod.collapse])
next
  case (Or_ltln \<phi> \<psi>)
    thus ?case
      by (simp add: combine_infinity_invariant[OF Or_ltln(1,2), unfolded prod.collapse])
next
  case (Until_ltln \<phi> \<psi>)
    thus ?case
      by (simp add: combine_infinity_invariant[OF Until_ltln(1,2), unfolded prod.collapse])
next
  case (Release_ltln \<phi> \<psi>)
    thus ?case
      by (simp add: combine_infinity_invariant[OF Release_ltln(1,2), unfolded prod.collapse])
next
  case (WeakUntil_ltln \<phi> \<psi>)
    thus ?case
      by (simp add: combine_infinity_invariant[OF WeakUntil_ltln(1,2), unfolded prod.collapse])
next
  case (StrongRelease_ltln \<phi> \<psi>)
    thus ?case
      by (simp add: combine_infinity_invariant[OF StrongRelease_ltln(1,2), unfolded prod.collapse])
next
  case (Next_ltln \<phi>)
    thus ?case
      by (simp add: split_def) (metis eSuc_infinity eSuc_inject)
qed auto

lemma rewrite_X_enat_correct:
  "w \<Turnstile>\<^sub>n \<phi> \<longleftrightarrow> w \<Turnstile>\<^sub>n to_ltln (rewrite_X_enat \<phi>)"
proof (induction \<phi> arbitrary: w)
  case (And_ltln \<phi> \<psi>)
    thus ?case
      using combine_and_or_semantics[OF rewrite_X_enat_infinity_invariant rewrite_X_enat_infinity_invariant] by fastforce
next
  case (Or_ltln \<phi> \<psi>)
    thus ?case
      using combine_and_or_semantics[OF rewrite_X_enat_infinity_invariant rewrite_X_enat_infinity_invariant] by fastforce
next
  case (Until_ltln \<phi> \<psi>)
    thus ?case
      unfolding rewrite_X_enat.simps combine_until_release_semantics[OF rewrite_X_enat_infinity_invariant rewrite_X_enat_infinity_invariant, unfolded prod.collapse] by fastforce
next
  case (Release_ltln \<phi> \<psi>)
    thus ?case
      unfolding rewrite_X_enat.simps combine_until_release_semantics[OF rewrite_X_enat_infinity_invariant rewrite_X_enat_infinity_invariant, unfolded prod.collapse] by fastforce
next
  case (WeakUntil_ltln \<phi> \<psi>)
    thus ?case
      unfolding rewrite_X_enat.simps combine_weak_until_strong_release_semantics[OF rewrite_X_enat_infinity_invariant rewrite_X_enat_infinity_invariant, unfolded prod.collapse] by fastforce
next
  case (StrongRelease_ltln \<phi> \<psi>)
    thus ?case
      unfolding rewrite_X_enat.simps combine_weak_until_strong_release_semantics[OF rewrite_X_enat_infinity_invariant rewrite_X_enat_infinity_invariant, unfolded prod.collapse] by fastforce
next
  case (Next_ltln \<phi>)
  moreover
    have " w \<Turnstile>\<^sub>n to_ltln (rewrite_X_enat (X\<^sub>n \<phi>)) \<longleftrightarrow> suffix 1 w \<Turnstile>\<^sub>n to_ltln (rewrite_X_enat \<phi>)"
      by (simp add: split_def; cases "snd (rewrite_X_enat \<phi>) \<noteq> \<infinity>")
         (auto simp: eSuc_def, auto simp: rewrite_X_enat_infinity_invariant eSuc_def dest: is_constant_semantics)
    ultimately
    show ?case
       using semantics_ltln.simps(7) by blast
qed auto

lemma rewrite_X_sound [simp]:
  "w \<Turnstile>\<^sub>n rewrite_X \<phi> \<longleftrightarrow> w \<Turnstile>\<^sub>n \<phi>"
  using rewrite_X_enat_correct unfolding rewrite_X_def Let_def by auto

subsection \<open>Pure Eventual, Pure Universal, and Suspendable Formulas\<close>

fun pure_eventual :: "'a ltln \<Rightarrow> bool"
where
  "pure_eventual true\<^sub>n = True"
| "pure_eventual false\<^sub>n = True"
| "pure_eventual (\<mu> and\<^sub>n \<mu>') = (pure_eventual \<mu> \<and> pure_eventual \<mu>')"
| "pure_eventual (\<mu> or\<^sub>n \<mu>') = (pure_eventual \<mu> \<and> pure_eventual \<mu>')"
| "pure_eventual (\<mu> U\<^sub>n \<mu>') = (\<mu> = true\<^sub>n \<or> pure_eventual \<mu>')"
| "pure_eventual (\<mu> R\<^sub>n \<mu>') = (pure_eventual \<mu> \<and> pure_eventual \<mu>')"
| "pure_eventual (\<mu> W\<^sub>n \<mu>') = (pure_eventual \<mu> \<and> pure_eventual \<mu>')"
| "pure_eventual (\<mu> M\<^sub>n \<mu>') = (pure_eventual \<mu> \<and> pure_eventual \<mu>' \<or> \<mu>' = true\<^sub>n)"
| "pure_eventual (X\<^sub>n \<mu>) = pure_eventual \<mu>"
| "pure_eventual _ = False"

fun pure_universal :: "'a ltln \<Rightarrow> bool"
where
  "pure_universal true\<^sub>n = True"
| "pure_universal false\<^sub>n = True"
| "pure_universal (\<nu> and\<^sub>n \<nu>') = (pure_universal \<nu> \<and> pure_universal \<nu>')"
| "pure_universal (\<nu> or\<^sub>n \<nu>') = (pure_universal \<nu> \<and> pure_universal \<nu>')"
| "pure_universal (\<nu> U\<^sub>n \<nu>') = (pure_universal \<nu> \<and> pure_universal \<nu>')"
| "pure_universal (\<nu> R\<^sub>n \<nu>') = (\<nu> = false\<^sub>n \<or> pure_universal \<nu>')"
| "pure_universal (\<nu> W\<^sub>n \<nu>') = (pure_universal \<nu> \<and> pure_universal \<nu>' \<or> \<nu>' = false\<^sub>n)"
| "pure_universal (\<nu> M\<^sub>n \<nu>') = (pure_universal \<nu> \<and> pure_universal \<nu>')"
| "pure_universal (X\<^sub>n \<nu>) = pure_universal \<nu>"
| "pure_universal _ = False"

fun suspendable :: "'a ltln \<Rightarrow> bool"
where
  "suspendable true\<^sub>n = True"
| "suspendable false\<^sub>n = True"
| "suspendable (\<xi> and\<^sub>n \<xi>') = (suspendable \<xi> \<and> suspendable \<xi>')"
| "suspendable (\<xi> or\<^sub>n \<xi>') = (suspendable \<xi> \<and> suspendable \<xi>')"
| "suspendable (\<phi> U\<^sub>n \<xi>) = (\<phi> = true\<^sub>n \<and> pure_universal \<xi> \<or> suspendable \<xi>)"
| "suspendable (\<phi> R\<^sub>n \<xi>) = (\<phi> = false\<^sub>n \<and> pure_eventual \<xi> \<or> suspendable \<xi>)"
| "suspendable (\<phi> W\<^sub>n \<xi>) = (suspendable \<phi> \<and> suspendable \<xi> \<or> pure_eventual \<phi> \<and> \<xi> = false\<^sub>n)"
| "suspendable (\<phi> M\<^sub>n \<xi>) = (suspendable \<phi> \<and> suspendable \<xi> \<or> pure_universal \<phi> \<and> \<xi> = true\<^sub>n)"
| "suspendable (X\<^sub>n \<xi>) = suspendable \<xi>"
| "suspendable _ = False"

lemma pure_eventual_left_append:
  "pure_eventual \<mu> \<Longrightarrow> w \<Turnstile>\<^sub>n \<mu> \<Longrightarrow> (u \<frown> w) \<Turnstile>\<^sub>n \<mu>"
proof (induction \<mu> arbitrary: u w)
  case (Until_ltln \<mu> \<mu>')
    moreover
    then obtain i where "suffix i w \<Turnstile>\<^sub>n \<mu>'"
      by auto
    hence "\<mu> = true\<^sub>n \<Longrightarrow> ?case"
      by simp (metis suffix_conc_length suffix_suffix)
    moreover
    have "pure_eventual \<mu>' \<Longrightarrow> (u \<frown> w) \<Turnstile>\<^sub>n \<mu>'"
      by (metis \<open>suffix i w \<Turnstile>\<^sub>n \<mu>'\<close> Until_ltln(2) prefix_suffix)
    hence "pure_eventual \<mu>' \<Longrightarrow> ?case"
      by force
    ultimately
    show ?case
      by fastforce
next
  case (Release_ltln \<mu> \<mu>')
    thus ?case
      by (cases "\<forall>i. suffix i w \<Turnstile>\<^sub>n \<mu>'"; simp_all)
         (metis linear suffix_conc_snd gr0I not_less0 prefix_suffix suffix_0)+
next
  case (WeakUntil_ltln \<mu> \<mu>')
    thus ?case
      by (cases "\<forall>i. suffix i w \<Turnstile>\<^sub>n \<mu>'"; simp_all)
         (metis zero_le le0 nat_le_linear prefix_suffix suffix_0 suffix_conc_length suffix_conc_snd suffix_subseq_join)+
next
  case (StrongRelease_ltln \<mu> \<mu>')
    moreover
    then obtain i where "suffix i w \<Turnstile>\<^sub>n \<mu> and\<^sub>n \<mu>'"
      by auto
    hence "\<mu>' = true\<^sub>n \<Longrightarrow> ?case"
      by simp (metis suffix_conc_length suffix_suffix)
    moreover
    have "pure_eventual \<mu> \<Longrightarrow> pure_eventual \<mu>' \<Longrightarrow> (u \<frown> w) \<Turnstile>\<^sub>n \<mu> and\<^sub>n \<mu>'"
      by (metis \<open>suffix i w \<Turnstile>\<^sub>n \<mu> and\<^sub>n \<mu>'\<close> calculation(1) calculation(2) prefix_suffix semantics_ltln.simps(5))
    hence "pure_eventual \<mu> \<Longrightarrow> pure_eventual \<mu>' \<Longrightarrow> ?case"
      by force
    ultimately
    show ?case
      by fastforce
qed (auto, metis diff_zero le_0_eq not_less_eq_eq suffix_conc_length suffix_conc_snd word_split)

lemma pure_universal_suffix_closed:
  "pure_universal \<nu> \<Longrightarrow> (u \<frown> w) \<Turnstile>\<^sub>n \<nu> \<Longrightarrow> w \<Turnstile>\<^sub>n \<nu>"
proof (induction \<nu> arbitrary: u w)
  case (Until_ltln \<nu> \<nu>')
    hence "\<exists>i. suffix i (u \<frown> w) \<Turnstile>\<^sub>n \<nu>' \<and> (\<forall>j<i. suffix j (u \<frown> w) \<Turnstile>\<^sub>n \<nu>)"
      using semantics_ltln.simps(8) by blast
    thus ?case
      by simp (metis Until_ltln(1-3) le_0_eq le_eq_less_or_eq le_less_linear prefix_suffix pure_universal.simps(5) suffix_conc_fst suffix_conc_snd)
next
  case (Release_ltln \<nu> \<nu>')
    moreover
    hence "\<forall>i. suffix i (u \<frown> w) \<Turnstile>\<^sub>n \<nu>' \<or> (\<exists>j<i. suffix j (u \<frown> w) \<Turnstile>\<^sub>n \<nu>)"
      by simp
    ultimately
    show ?case
      by simp (metis semantics_ltln.simps(2) not_less0 prefix_suffix suffix_0 suffix_conc_length suffix_suffix)
next
  case (WeakUntil_ltln \<nu> \<nu>')
    moreover
    hence "\<forall>i. suffix i (u \<frown> w) \<Turnstile>\<^sub>n \<nu> \<or> (\<exists>j\<le>i. suffix j (u \<frown> w) \<Turnstile>\<^sub>n \<nu>')"
      by simp
    ultimately
    show ?case
      by simp (metis (full_types) le_antisym prefix_suffix semantics_ltln.simps(2) suffix_0 suffix_conc_length suffix_suffix zero_le)
next
  case (StrongRelease_ltln \<nu> \<nu>')
    hence "\<exists>i. suffix i (u \<frown> w) \<Turnstile>\<^sub>n \<nu> \<and> (\<forall>j\<le>i. suffix j (u \<frown> w) \<Turnstile>\<^sub>n \<nu>')"
      using semantics_ltln.simps(11) by blast
    thus ?case
      by simp (metis StrongRelease_ltln(1-3) diff_is_0_eq nat_le_linear prefix_conc_length prefix_suffix pure_universal.simps(8) subsequence_length suffix_conc_snd suffix_subseq_join)
next
  case (Next_ltln \<mu>)
    thus ?case
      by (metis prefix_suffix pure_universal.simps(9) semantics_ltln.simps(7) semiring_normalization_rules(24) suffix_conc_length suffix_suffix)
qed auto

lemma suspendable_prefix_invariant:
  "suspendable \<xi> \<Longrightarrow> (u \<frown> w) \<Turnstile>\<^sub>n \<xi> \<longleftrightarrow> w \<Turnstile>\<^sub>n \<xi>"
proof (induction \<xi> arbitrary: u w)
  case (Until_ltln \<xi> \<xi>')
    show ?case
    proof (cases "suspendable \<xi>'")
      case False
        hence "\<xi> = true\<^sub>n" and "pure_universal \<xi>'"
          using Until_ltln by simp+
        thus ?thesis
          by (simp; metis (no_types) linear pure_universal_suffix_closed suffix_conc_fst suffix_conc_length suffix_conc_snd suffix_suffix)
    qed (simp; metis Until_ltln(2) not_less0 prefix_suffix)
next
  case (Release_ltln \<xi> \<xi>')
    show ?case
    proof (cases "suspendable \<xi>'")
      case False
        hence "\<xi> = false\<^sub>n" and "pure_eventual \<xi>'"
          using Release_ltln by simp+
        thus ?thesis
          by (simp; metis (no_types) le_iff_add add_diff_cancel_left' linear pure_eventual_left_append suffix_0 suffix_conc_fst suffix_conc_snd)
    qed (simp; metis Release_ltln(2) not_less0 prefix_suffix)
next
  case (WeakUntil_ltln \<xi> \<xi>')
    show ?case
    proof (cases "suspendable \<xi> \<and> suspendable \<xi>'")
      case False
        hence "\<xi>' = false\<^sub>n" and "pure_eventual \<xi>"
          using WeakUntil_ltln by simp+
        thus ?thesis
          by (simp; metis (no_types) le_iff_add add_diff_cancel_left' linear pure_eventual_left_append suffix_0 suffix_conc_fst suffix_conc_snd)
      qed (simp; metis (full_types) WeakUntil_ltln.IH prefix_suffix)
next
  case (StrongRelease_ltln \<xi> \<xi>')
    show ?case
    proof (cases "suspendable \<xi> \<and> suspendable \<xi>'")
      case False
        hence "\<xi>' = true\<^sub>n" and "pure_universal \<xi>"
          using StrongRelease_ltln by simp+
        thus ?thesis
          by (simp; metis (no_types) linear pure_universal_suffix_closed suffix_conc_fst suffix_conc_length suffix_conc_snd suffix_suffix)
    qed (simp; metis (full_types) StrongRelease_ltln.IH(1) StrongRelease_ltln.IH(2) prefix_suffix)
qed (simp_all, metis prefix_suffix)

theorem pure_eventual_until_simp:
  assumes "pure_eventual \<mu>"
  shows "w \<Turnstile>\<^sub>n \<phi> U\<^sub>n \<mu> \<longleftrightarrow> w \<Turnstile>\<^sub>n \<mu>"
proof -
  have "\<And>i. suffix i w \<Turnstile>\<^sub>n \<mu> \<Longrightarrow> w \<Turnstile>\<^sub>n \<mu>"
    using pure_eventual_left_append[OF assms] prefix_suffix by metis
  thus ?thesis
    by force
qed

theorem pure_universal_release_simp:
  assumes "pure_universal \<nu>"
  shows "w \<Turnstile>\<^sub>n \<phi> R\<^sub>n \<nu> \<longleftrightarrow> w \<Turnstile>\<^sub>n \<nu>"
proof -
  have "\<And>i. w \<Turnstile>\<^sub>n \<nu> \<Longrightarrow> suffix i w \<Turnstile>\<^sub>n \<nu>"
    using pure_universal_suffix_closed[OF assms] prefix_suffix by metis
  thus ?thesis
    by force
qed

theorem pure_universal_weak_until_simp:
  assumes "pure_universal \<phi>" and "pure_universal \<psi>"
  shows "w \<Turnstile>\<^sub>n \<phi> W\<^sub>n \<psi> \<longleftrightarrow> w \<Turnstile>\<^sub>n \<phi> or\<^sub>n \<psi>"
proof -
  have "\<And>i. w \<Turnstile>\<^sub>n \<phi> \<Longrightarrow> suffix i w \<Turnstile>\<^sub>n \<phi>" and "\<And>i. w \<Turnstile>\<^sub>n \<psi> \<Longrightarrow> suffix i w \<Turnstile>\<^sub>n \<psi>"
    using assms pure_universal_suffix_closed prefix_suffix by metis+
  thus ?thesis
    by force
qed

theorem pure_eventual_strong_release_simp:
  assumes "pure_eventual \<phi>" and "pure_eventual \<psi>"
  shows "w \<Turnstile>\<^sub>n \<phi> M\<^sub>n \<psi> \<longleftrightarrow> w \<Turnstile>\<^sub>n \<phi> and\<^sub>n \<psi>"
proof -
  have "\<And>i. suffix i w \<Turnstile>\<^sub>n \<phi> \<Longrightarrow> w \<Turnstile>\<^sub>n \<phi>" and "\<And>i. suffix i w \<Turnstile>\<^sub>n \<psi> \<Longrightarrow> w \<Turnstile>\<^sub>n \<psi>"
    using assms pure_eventual_left_append prefix_suffix by metis+
  thus ?thesis
    by force
qed

theorem suspendable_formula_simp:
  assumes "suspendable \<xi>"
  shows "w \<Turnstile>\<^sub>n X\<^sub>n \<xi> \<longleftrightarrow> w \<Turnstile>\<^sub>n \<xi>" (is ?t1)
    and "w \<Turnstile>\<^sub>n \<phi> U\<^sub>n \<xi> \<longleftrightarrow> w \<Turnstile>\<^sub>n \<xi>" (is ?t2)
    and "w \<Turnstile>\<^sub>n \<phi> R\<^sub>n \<xi> \<longleftrightarrow> w \<Turnstile>\<^sub>n \<xi>" (is ?t3)
proof -
  have "\<And>i. suffix i w \<Turnstile>\<^sub>n \<xi> \<longleftrightarrow> w \<Turnstile>\<^sub>n \<xi>"
    using suspendable_prefix_invariant[OF assms] prefix_suffix by metis
  thus ?t1 ?t2 ?t3
    by force+
qed

theorem suspendable_formula_simp2:
  assumes "suspendable \<phi>" and "suspendable \<psi>"
  shows "w \<Turnstile>\<^sub>n \<phi> W\<^sub>n \<psi> \<longleftrightarrow> w \<Turnstile>\<^sub>n \<phi> or\<^sub>n \<psi>" (is ?t1)
    and "w \<Turnstile>\<^sub>n \<phi> M\<^sub>n \<psi> \<longleftrightarrow> w \<Turnstile>\<^sub>n \<phi> and\<^sub>n \<psi>" (is ?t2)
proof -
  have "\<And>i. suffix i w \<Turnstile>\<^sub>n \<phi> \<longleftrightarrow> w \<Turnstile>\<^sub>n \<phi>" and "\<And>i. suffix i w \<Turnstile>\<^sub>n \<psi> \<longleftrightarrow> w \<Turnstile>\<^sub>n \<psi>"
    using assms suspendable_prefix_invariant prefix_suffix by metis+
  thus ?t1 ?t2
    by force+
qed

fun rewrite_modal :: "'a ltln \<Rightarrow> 'a ltln"
where
  "rewrite_modal true\<^sub>n = true\<^sub>n"
| "rewrite_modal false\<^sub>n = false\<^sub>n"
| "rewrite_modal (\<phi> and\<^sub>n \<psi>) = (rewrite_modal \<phi> and\<^sub>n rewrite_modal \<psi>)"
| "rewrite_modal (\<phi> or\<^sub>n \<psi>) = (rewrite_modal \<phi> or\<^sub>n rewrite_modal \<psi>)"
| "rewrite_modal (\<phi> U\<^sub>n \<psi>) = (if pure_eventual \<psi> \<or> suspendable \<psi> then rewrite_modal \<psi> else (rewrite_modal \<phi> U\<^sub>n rewrite_modal \<psi>))"
| "rewrite_modal (\<phi> R\<^sub>n \<psi>) = (if pure_universal \<psi> \<or> suspendable \<psi> then rewrite_modal \<psi> else (rewrite_modal \<phi> R\<^sub>n rewrite_modal \<psi>))"
| "rewrite_modal (\<phi> W\<^sub>n \<psi>) = (if pure_universal \<phi> \<and> pure_universal \<psi> \<or> suspendable \<phi> \<and> suspendable \<psi> then (rewrite_modal \<phi> or\<^sub>n rewrite_modal \<psi>) else (rewrite_modal \<phi> W\<^sub>n rewrite_modal \<psi>))"
| "rewrite_modal (\<phi> M\<^sub>n \<psi>) = (if pure_eventual \<phi> \<and> pure_eventual \<psi> \<or> suspendable \<phi> \<and> suspendable \<psi> then (rewrite_modal \<phi> and\<^sub>n rewrite_modal \<psi>) else (rewrite_modal \<phi> M\<^sub>n rewrite_modal \<psi>))"
| "rewrite_modal (X\<^sub>n \<phi>) = (if suspendable \<phi> then rewrite_modal \<phi> else X\<^sub>n (rewrite_modal \<phi>))"
| "rewrite_modal \<phi> = \<phi>"

lemma rewrite_modal_sound [simp]:
  "w \<Turnstile>\<^sub>n rewrite_modal \<phi> \<longleftrightarrow> w \<Turnstile>\<^sub>n \<phi>"
proof (induction \<phi> arbitrary: w)
  case (Until_ltln \<phi> \<psi>)
    thus ?case
      apply (cases "pure_eventual \<psi> \<or> suspendable \<psi>")
      apply (insert pure_eventual_until_simp[of \<psi>] suspendable_formula_simp[of \<psi>])
      apply fastforce+
      done
next
  case (Release_ltln \<phi> \<psi>)
    thus ?case
      apply (cases "pure_universal \<psi> \<or> suspendable \<psi>")
      apply (insert pure_universal_release_simp[of \<psi>] suspendable_formula_simp[of \<psi>])
      apply fastforce+
      done
next
  case (WeakUntil_ltln \<phi> \<psi>)
    thus ?case
      apply (cases "pure_universal \<phi> \<and> pure_universal \<psi> \<or> suspendable \<phi> \<and> suspendable \<psi>")
      apply (insert pure_universal_weak_until_simp[of \<phi> \<psi>] suspendable_formula_simp2[of \<phi> \<psi>])
      apply fastforce+
      done
next
  case (StrongRelease_ltln \<phi> \<psi>)
    thus ?case
      apply (cases "pure_eventual \<phi> \<and> pure_eventual \<psi> \<or> suspendable \<phi> \<and> suspendable \<psi>")
      apply (insert pure_eventual_strong_release_simp[of \<phi> \<psi>] suspendable_formula_simp2[of \<phi> \<psi>])
      apply fastforce+
      done
next
  case (Next_ltln \<phi>)
    thus ?case
      apply (cases "suspendable \<phi>")
      apply (insert suspendable_formula_simp[of \<phi>])
      apply fastforce+
      done
qed auto

lemma rewrite_modal_size:
  "size (rewrite_modal \<phi>) \<le> size \<phi>"
  by (induction \<phi>) auto

subsection \<open>Syntactical Implication Based Simplification\<close>

inductive syntactical_implies :: "'a ltln \<Rightarrow> 'a ltln \<Rightarrow> bool" ("_ \<turnstile>\<^sub>s _" [80, 80])
where
  "_ \<turnstile>\<^sub>s true\<^sub>n"
| "false\<^sub>n \<turnstile>\<^sub>s _"
| "\<phi> = \<phi> \<Longrightarrow> \<phi> \<turnstile>\<^sub>s \<phi>"

| "\<phi> \<turnstile>\<^sub>s \<chi> \<Longrightarrow> (\<phi> and\<^sub>n \<psi>) \<turnstile>\<^sub>s \<chi>"
| "\<psi> \<turnstile>\<^sub>s \<chi> \<Longrightarrow> (\<phi> and\<^sub>n \<psi>) \<turnstile>\<^sub>s \<chi>"
| "\<phi> \<turnstile>\<^sub>s \<psi> \<Longrightarrow> \<phi> \<turnstile>\<^sub>s \<chi> \<Longrightarrow> \<phi> \<turnstile>\<^sub>s (\<psi> and\<^sub>n \<chi>)"

| "\<phi> \<turnstile>\<^sub>s \<psi> \<Longrightarrow> \<phi> \<turnstile>\<^sub>s (\<psi> or\<^sub>n \<chi>)"
| "\<phi> \<turnstile>\<^sub>s \<chi> \<Longrightarrow> \<phi> \<turnstile>\<^sub>s (\<psi> or\<^sub>n \<chi>)"
| "\<phi> \<turnstile>\<^sub>s \<chi> \<Longrightarrow> \<psi> \<turnstile>\<^sub>s \<chi> \<Longrightarrow> (\<phi> or\<^sub>n \<psi>) \<turnstile>\<^sub>s \<chi>"

| "\<phi> \<turnstile>\<^sub>s \<chi> \<Longrightarrow> \<phi> \<turnstile>\<^sub>s (\<psi> U\<^sub>n \<chi>)"
| "\<phi> \<turnstile>\<^sub>s \<chi> \<Longrightarrow> \<psi> \<turnstile>\<^sub>s \<chi> \<Longrightarrow> (\<phi> U\<^sub>n \<psi>) \<turnstile>\<^sub>s \<chi>"
| "\<phi> \<turnstile>\<^sub>s \<chi> \<Longrightarrow> \<psi> \<turnstile>\<^sub>s \<nu> \<Longrightarrow> (\<phi> U\<^sub>n \<psi>) \<turnstile>\<^sub>s (\<chi> U\<^sub>n \<nu>)"

| "\<chi> \<turnstile>\<^sub>s \<phi> \<Longrightarrow> (\<psi> R\<^sub>n \<chi>) \<turnstile>\<^sub>s \<phi>"
| "\<chi> \<turnstile>\<^sub>s \<phi> \<Longrightarrow> \<chi> \<turnstile>\<^sub>s \<psi> \<Longrightarrow> \<chi> \<turnstile>\<^sub>s (\<phi> R\<^sub>n \<psi>)"
| "\<phi> \<turnstile>\<^sub>s \<chi> \<Longrightarrow> \<psi> \<turnstile>\<^sub>s \<nu> \<Longrightarrow> (\<phi> R\<^sub>n \<psi>) \<turnstile>\<^sub>s (\<chi> R\<^sub>n \<nu>)"

| "(false\<^sub>n R\<^sub>n \<phi>) \<turnstile>\<^sub>s \<psi> \<Longrightarrow> (false\<^sub>n R\<^sub>n \<phi>) \<turnstile>\<^sub>s X\<^sub>n \<psi>"
| "\<phi> \<turnstile>\<^sub>s (true\<^sub>n U\<^sub>n \<psi>) \<Longrightarrow> (X\<^sub>n \<phi>) \<turnstile>\<^sub>s (true\<^sub>n U\<^sub>n \<psi>)"
| "\<phi> \<turnstile>\<^sub>s \<psi> \<Longrightarrow> (X\<^sub>n \<phi>) \<turnstile>\<^sub>s (X\<^sub>n \<psi>)"

lemma syntactical_implies_correct:
  "\<phi> \<turnstile>\<^sub>s \<psi> \<Longrightarrow> w \<Turnstile>\<^sub>n \<phi> \<Longrightarrow> w \<Turnstile>\<^sub>n \<psi>"
  by (induction arbitrary: w rule: syntactical_implies.induct; auto; force)

fun rewrite_syn_imp
where
  "rewrite_syn_imp (\<phi> and\<^sub>n \<psi>) = (
    if \<phi> \<turnstile>\<^sub>s \<psi> then
      rewrite_syn_imp \<phi>
    else if \<psi> \<turnstile>\<^sub>s \<phi> then
      rewrite_syn_imp \<psi>
    else if \<phi> \<turnstile>\<^sub>s (not\<^sub>n \<psi>) \<or> \<psi> \<turnstile>\<^sub>s (not\<^sub>n \<phi>) then
      false\<^sub>n
    else
      mk_and (rewrite_syn_imp \<phi>) (rewrite_syn_imp \<psi>))"
| "rewrite_syn_imp (\<phi> or\<^sub>n \<psi>) = (
    if \<phi> \<turnstile>\<^sub>s \<psi> then
      rewrite_syn_imp \<psi>
    else if \<psi> \<turnstile>\<^sub>s \<phi> then
      rewrite_syn_imp \<phi>
    else if (not\<^sub>n \<phi>) \<turnstile>\<^sub>s \<psi> \<or> (not\<^sub>n \<psi>) \<turnstile>\<^sub>s \<phi> then
      true\<^sub>n
    else
      mk_or (rewrite_syn_imp \<phi>) (rewrite_syn_imp \<psi>))"
| "rewrite_syn_imp (\<phi> U\<^sub>n \<psi>) = (
    if \<phi> \<turnstile>\<^sub>s \<psi> then
      rewrite_syn_imp \<psi>
    else if (not\<^sub>n \<phi>) \<turnstile>\<^sub>s \<psi> then
      mk_finally (rewrite_syn_imp \<psi>)
    else
      mk_until (rewrite_syn_imp \<phi>) (rewrite_syn_imp \<psi>))"
| "rewrite_syn_imp (\<phi> R\<^sub>n \<psi>) = (
    if \<psi> \<turnstile>\<^sub>s \<phi> then
      rewrite_syn_imp \<psi>
    else if \<psi> \<turnstile>\<^sub>s (not\<^sub>n \<phi>) then
      mk_globally (rewrite_syn_imp \<psi>)
    else
      mk_release (rewrite_syn_imp \<phi>) (rewrite_syn_imp \<psi>))"
| "rewrite_syn_imp (X\<^sub>n \<phi>) = mk_next (rewrite_syn_imp \<phi>)"
| "rewrite_syn_imp \<phi> = \<phi>"

lemma rewrite_syn_imp_sound:
  "w \<Turnstile>\<^sub>n rewrite_syn_imp \<phi> \<longleftrightarrow> w \<Turnstile>\<^sub>n \<phi>"
proof (induction \<phi> arbitrary: w)
  case And_ltln
    thus ?case
      by (simp add: Let_def; metis syntactical_implies_correct not\<^sub>n_semantics)
next
  case (Or_ltln \<phi> \<psi>)
    moreover
    have "(not\<^sub>n \<phi>) \<turnstile>\<^sub>s \<psi> \<Longrightarrow> \<forall>w. w \<Turnstile>\<^sub>n \<phi> or\<^sub>n \<psi>"
      by (auto intro: syntactical_implies_correct[of "not\<^sub>n \<phi>"])
    moreover
    have "(not\<^sub>n \<psi>) \<turnstile>\<^sub>s \<phi> \<Longrightarrow> \<forall>w. w \<Turnstile>\<^sub>n \<phi> or\<^sub>n \<psi>"
      by (auto intro: syntactical_implies_correct[of "not\<^sub>n \<psi>"])
    ultimately
    show ?case
      by (auto intro: syntactical_implies_correct)
next
  case (Until_ltln \<phi> \<psi>)
    moreover
    have "\<phi> \<turnstile>\<^sub>s \<psi> \<Longrightarrow> ?case"
      by (force simp add: Until_ltln dest: syntactical_implies_correct)
    moreover
    {
      assume A: "(not\<^sub>n \<phi>) \<turnstile>\<^sub>s \<psi>" and B: "\<not> \<phi> \<turnstile>\<^sub>s \<psi>"
      hence [simp]: "rewrite_syn_imp (\<phi> U\<^sub>n \<psi>) = mk_finally (rewrite_syn_imp \<psi>)"
        by simp
      {
        assume "\<exists>i. suffix i w \<Turnstile>\<^sub>n \<psi>"
        moreover
        define i where "i \<equiv> LEAST i. suffix i w \<Turnstile>\<^sub>n \<psi>"
        ultimately
        have "\<forall>j < i. \<not>suffix j w \<Turnstile>\<^sub>n \<psi>" and "suffix i w \<Turnstile>\<^sub>n \<psi>"
          by (blast dest: not_less_Least , metis LeastI \<open>\<exists>i. suffix i w \<Turnstile>\<^sub>n \<psi>\<close> i_def)
        hence "\<forall>j < i. suffix j w \<Turnstile>\<^sub>n \<phi>" and "suffix i w \<Turnstile>\<^sub>n \<psi>"
          using syntactical_implies_correct[OF A] by auto
      }
      hence ?case
        by (simp del: rewrite_syn_imp.simps; unfold Until_ltln(2)) blast
    }
    ultimately
    show ?case
      by fastforce
next
  case (Release_ltln \<phi> \<psi>)
    moreover
    have "\<psi> \<turnstile>\<^sub>s \<phi> \<Longrightarrow> ?case"
      by (force simp add: Release_ltln dest: syntactical_implies_correct)
    moreover
    {
      assume A: "\<psi> \<turnstile>\<^sub>s (not\<^sub>n \<phi>)" and B: "\<not> \<psi> \<turnstile>\<^sub>s \<phi>"
      hence [simp]: "rewrite_syn_imp (\<phi> R\<^sub>n \<psi>) = mk_globally (rewrite_syn_imp \<psi>)"
        by simp
      {
        assume "\<exists>i. \<not>suffix i w \<Turnstile>\<^sub>n \<psi>"
        moreover
        define i where "i \<equiv> LEAST i. \<not>suffix i w \<Turnstile>\<^sub>n \<psi>"
        ultimately
        have "\<forall>j < i. suffix j w \<Turnstile>\<^sub>n \<psi>" and "\<not> suffix i w \<Turnstile>\<^sub>n \<psi>"
          by (blast dest: not_less_Least , metis LeastI \<open>\<exists>i. \<not>suffix i w \<Turnstile>\<^sub>n \<psi>\<close> i_def)
        hence "\<forall>j < i. \<not>suffix j w \<Turnstile>\<^sub>n \<phi>" and "\<not> suffix i w \<Turnstile>\<^sub>n \<psi>"
          using syntactical_implies_correct[OF A] by auto
      }
      hence ?case
        by (simp del: rewrite_syn_imp.simps; unfold Release_ltln(2)) blast
    }
    ultimately
    show ?case
      by fastforce
qed auto

subsection \<open>Iterated Rewriting\<close>

fun iterate
where
  "iterate f x 0 = x"
| "iterate f x (Suc n) = (let x' = f x in if x = x' then x else iterate f x' n)"

definition
  "rewrite_iter_fast \<phi> \<equiv> iterate (rewrite_modal o rewrite_X) \<phi> (size \<phi>)"

definition
  "rewrite_iter_slow \<phi> \<equiv> iterate (rewrite_syn_imp o rewrite_modal o rewrite_X) \<phi> (size \<phi>)"

text \<open>The rewriting functions defined in the previous subsections can be used as-is. However, in the
  most cases one wants to iterate these rules until the formula cannot be simplified further.
  @{const rewrite_iter_fast} pulls X operators up in the syntax tree and the uses the
  "modal" simplification rules. @{const rewrite_iter_slow} additionally tries to simplify the
  formula using syntactic implication checking.\<close>

lemma iterate_sound:
  assumes "\<And>\<phi>. w \<Turnstile>\<^sub>n f \<phi> \<longleftrightarrow> w \<Turnstile>\<^sub>n \<phi>"
  shows "w \<Turnstile>\<^sub>n iterate f \<phi> n \<longleftrightarrow> w \<Turnstile>\<^sub>n \<phi>"
  by (induction n arbitrary: \<phi>; simp add: assms Let_def)

theorem rewrite_iter_fast_sound [simp]:
  "w \<Turnstile>\<^sub>n rewrite_iter_fast \<phi> \<longleftrightarrow> w \<Turnstile>\<^sub>n \<phi>"
  using iterate_sound[of _ "rewrite_modal o rewrite_X"]
  unfolding comp_def rewrite_modal_sound rewrite_X_sound rewrite_iter_fast_def
  by blast

theorem rewrite_iter_slow_sound [simp]:
  "w \<Turnstile>\<^sub>n rewrite_iter_slow \<phi> \<longleftrightarrow> w \<Turnstile>\<^sub>n \<phi>"
  using iterate_sound[of _ "rewrite_syn_imp o rewrite_modal o rewrite_X"]
  unfolding comp_def rewrite_modal_sound rewrite_X_sound rewrite_syn_imp_sound rewrite_iter_slow_def
  by blast

subsection \<open>Preservation of atoms\<close>

lemma iterate_atoms:
  assumes
    "\<And>\<phi>. atoms_ltln (f \<phi>) \<subseteq> atoms_ltln \<phi>"
  shows
    "atoms_ltln (iterate f \<phi> n) \<subseteq> atoms_ltln \<phi>"
  by (induction n arbitrary: \<phi>) (auto, metis (mono_tags, lifting) assms in_mono)

lemma rewrite_modal_atoms:
  "atoms_ltln (rewrite_modal \<phi>) \<subseteq> atoms_ltln \<phi>"
  by (induction \<phi>) auto

lemma mk_and_atoms:
  "atoms_ltln (mk_and \<phi> \<psi>) \<subseteq> atoms_ltln \<phi> \<union> atoms_ltln \<psi>"
  by (auto simp: mk_and_def split: ltln.splits)

lemma mk_or_atoms:
  "atoms_ltln (mk_or \<phi> \<psi>) \<subseteq> atoms_ltln \<phi> \<union> atoms_ltln \<psi>"
  by (auto simp: mk_or_def split: ltln.splits)

lemma remove_strong_ops_atoms:
  "atoms_ltln (remove_strong_ops \<phi>) \<subseteq> atoms_ltln \<phi>"
  by (induction \<phi>) auto

lemma remove_weak_ops_atoms:
  "atoms_ltln (remove_weak_ops \<phi>) \<subseteq> atoms_ltln \<phi>"
  by (induction \<phi>) auto

lemma mk_globally_atoms:
  "atoms_ltln (mk_globally \<phi>) \<subseteq> atoms_ltln \<phi>"
  by (auto simp: mk_globally_def split: ltln.splits) (insert remove_weak_ops_atoms, fast+)

lemma mk_until_atoms:
  "atoms_ltln (mk_until \<phi> \<psi>) \<subseteq> atoms_ltln \<phi> \<union> atoms_ltln \<psi>"
  by (auto simp: mk_until_def split: ltln.splits) (insert mk_finally_atoms, fastforce+)

lemma mk_release_atoms:
  "atoms_ltln (mk_release \<phi> \<psi>) \<subseteq> atoms_ltln \<phi> \<union> atoms_ltln \<psi>"
  by (auto simp: mk_release_def split: ltln.splits) (insert mk_globally_atoms, fastforce+)

lemma mk_weak_until_atoms:
  "atoms_ltln (mk_weak_until \<phi> \<psi>) \<subseteq> atoms_ltln \<phi> \<union> atoms_ltln \<psi>"
  by (auto simp: mk_weak_until_def split: ltln.splits) (insert mk_globally_atoms, fastforce+)

lemma mk_strong_release_atoms:
  "atoms_ltln (mk_strong_release \<phi> \<psi>) \<subseteq> atoms_ltln \<phi> \<union> atoms_ltln \<psi>"
  by (auto simp: mk_strong_release_def split: ltln.splits) (insert mk_finally_atoms, fastforce+)

lemma mk_next_atoms:
  "atoms_ltln (mk_next \<phi>) = atoms_ltln \<phi>"
  by (auto simp: mk_next_def split: ltln.splits)

lemma mk_next_pow_atoms:
  "atoms_ltln (mk_next_pow n \<phi>) = atoms_ltln \<phi>"
  by (induction n) (auto simp: mk_next_pow_def split: ltln.splits)

lemma combine_atoms:
  assumes
    "\<And>\<phi> \<psi>. atoms_ltln (f \<phi> \<psi>) \<subseteq> atoms_ltln \<phi> \<union> atoms_ltln \<psi>"
  shows
    "atoms_ltln (fst (combine f x y)) \<subseteq> atoms_ltln (fst x) \<union> atoms_ltln (fst y)"
  by (metis assms fst_combine mk_next_pow_atoms prod.collapse)

lemmas combine_mk_atoms =
  combine_atoms[OF mk_and_atoms]
  combine_atoms[OF mk_or_atoms]
  combine_atoms[OF mk_until_atoms]
  combine_atoms[OF mk_release_atoms]
  combine_atoms[OF mk_weak_until_atoms]
  combine_atoms[OF mk_strong_release_atoms]

lemma rewrite_X_enat_atoms:
  "atoms_ltln (fst (rewrite_X_enat \<phi>)) \<subseteq> atoms_ltln \<phi>"
  by (induction \<phi>) (simp_all add: case_prod_beta, insert combine_mk_atoms, fast+)

lemma rewrite_X_atoms:
  "atoms_ltln (rewrite_X \<phi>) \<subseteq> atoms_ltln \<phi>"
  by (induction \<phi>) (simp_all add: rewrite_X_def mk_next_pow_atoms case_prod_beta, insert combine_mk_atoms, fast+)

lemma rewrite_syn_imp_atoms:
  "atoms_ltln (rewrite_syn_imp \<phi>) \<subseteq> atoms_ltln \<phi>"
proof (induction \<phi>)
  case (And_ltln \<phi>1 \<phi>2)
  then show ?case
    using mk_and_atoms by simp fast
next
  case (Or_ltln \<phi>1 \<phi>2)
  then show ?case
    using mk_or_atoms by simp fast
next
  case (Next_ltln \<phi>)
  then show ?case
    using mk_next_atoms by simp fast
next
  case (Until_ltln \<phi>1 \<phi>2)
  then show ?case
    using mk_finally_atoms mk_until_atoms by simp fast
next
  case (Release_ltln \<phi>1 \<phi>2)
  then show ?case
    using mk_globally_atoms mk_release_atoms by simp fast
qed simp_all

lemma rewrite_iter_fast_atoms:
  "atoms_ltln (rewrite_iter_fast \<phi>) \<subseteq> atoms_ltln \<phi>"
proof -
  have 1: "\<And>\<phi>. atoms_ltln (rewrite_modal (rewrite_X \<phi>)) \<subseteq> atoms_ltln \<phi>"
    using rewrite_modal_atoms rewrite_X_atoms by force

  show ?thesis
    by (simp add: rewrite_iter_fast_def 1 iterate_atoms)
qed

lemma rewrite_iter_slow_atoms:
  "atoms_ltln (rewrite_iter_slow \<phi>) \<subseteq> atoms_ltln \<phi>"
proof -
  have 1: "\<And>\<phi>. atoms_ltln (rewrite_syn_imp (rewrite_modal (rewrite_X \<phi>))) \<subseteq> atoms_ltln \<phi>"
    using rewrite_syn_imp_atoms rewrite_modal_atoms rewrite_X_atoms by force

  show ?thesis
    by (simp add: rewrite_iter_slow_def 1 iterate_atoms)
qed

subsection \<open>Simplifier\<close>

text \<open>We now define a convenience wrapper for the rewriting engine\<close>

datatype mode = Nop | Fast | Slow

fun simplify :: "mode \<Rightarrow> 'a ltln \<Rightarrow> 'a ltln"
where
  "simplify Nop = id"
| "simplify Fast = rewrite_iter_fast"
| "simplify Slow = rewrite_iter_slow"

theorem simplify_correct:
  "w \<Turnstile>\<^sub>n simplify m \<phi> \<longleftrightarrow> w \<Turnstile>\<^sub>n \<phi>"
  by (cases m) simp+

lemma simplify_atoms:
  "atoms_ltln (simplify m \<phi>) \<subseteq> atoms_ltln \<phi>"
  by (cases m) (insert rewrite_iter_fast_atoms rewrite_iter_slow_atoms, fastforce+)

subsection \<open>Code Generation\<close>

code_pred syntactical_implies .

export_code simplify checking

lemma "rewrite_iter_fast (F\<^sub>n (G\<^sub>n (X\<^sub>n prop\<^sub>n(''a'')))) = (F\<^sub>n (G\<^sub>n prop\<^sub>n(''a'')))"
  by eval

lemma "rewrite_iter_fast (X\<^sub>n prop\<^sub>n(''a'') U\<^sub>n (X\<^sub>n nprop\<^sub>n(''a''))) = X\<^sub>n (prop\<^sub>n(''a'') U\<^sub>n nprop\<^sub>n(''a''))"
  by eval

lemma "rewrite_iter_slow (X\<^sub>n prop\<^sub>n(''a'') U\<^sub>n (X\<^sub>n nprop\<^sub>n(''a''))) = X\<^sub>n (F\<^sub>n nprop\<^sub>n(''a''))"
  by eval

end


(* Martin Kleppmann, University of Cambridge
   Victor B. F. Gomes, University of Cambridge
   Dominic P. Mulligan, Arm Research, Cambridge
   Alastair Beresford, University of Cambridge
*)

section\<open>The Replicated Growable Array (RGA)\<close>

text\<open>The RGA algorithm \<^cite>\<open>"Roh:2011dw"\<close> is a replicated list (or
collaborative text-editing) algorithm. In this section we prove that
RGA satisfies our list specification. The Isabelle/HOL definition of
RGA in this section is based on our prior work on formally verifying
CRDTs \<^cite>\<open>"Gomes:2017gy" and "Gomes:2017vo"\<close>.\<close>

theory RGA
  imports Insert_Spec
begin

fun insert_body :: "'oid::{linorder} list \<Rightarrow> 'oid \<Rightarrow> 'oid list" where
  "insert_body []       e = [e]" |
  "insert_body (x # xs) e =
     (if x < e then e # x # xs
               else x # insert_body xs e)"

fun insert_rga :: "'oid::{linorder} list \<Rightarrow> ('oid \<times> 'oid option) \<Rightarrow> 'oid list" where
  "insert_rga  xs      (e, None)   = insert_body xs e" |
  "insert_rga  []      (e, Some i) = []" |
  "insert_rga (x # xs) (e, Some i) =
     (if x = i then
        x # insert_body xs e
      else
        x # insert_rga xs (e, Some i))"

definition interp_rga :: "('oid::{linorder} \<times> 'oid option) list \<Rightarrow> 'oid list" where
  "interp_rga ops \<equiv> foldl insert_rga [] ops"

subsection\<open>Commutativity of \isa{insert-rga}\<close>

lemma insert_body_set_ins [simp]:
  shows  "set (insert_body xs e) = insert e (set xs)"
  by (induction xs, auto)

lemma insert_rga_set_ins:
  assumes "i \<in> set xs"
  shows "set (insert_rga xs (oid, Some i)) = insert oid (set xs)"
  using assms by (induction xs, auto)

lemma insert_body_commutes:
  shows "insert_body (insert_body xs e1) e2 = insert_body (insert_body xs e2) e1"
  by (induction xs, auto)

lemma insert_rga_insert_body_commute:
  assumes "i2 \<noteq> Some e1"
  shows "insert_rga (insert_body xs e1) (e2, i2) = insert_body (insert_rga xs (e2, i2)) e1"
  using assms by (induction xs; cases i2) (auto simp add: insert_body_commutes)

lemma insert_rga_None_commutes:
  assumes "i2 \<noteq> Some e1"
  shows "insert_rga (insert_rga xs (e1, None)) (e2, i2  ) =
         insert_rga (insert_rga xs (e2, i2  )) (e1, None)"
  using assms by (induction xs; cases i2) (auto simp add: insert_body_commutes)

lemma insert_rga_nonexistent:
  assumes "i \<notin> set xs"
  shows "insert_rga xs (e, Some i) = xs"
  using assms by (induction xs, auto)

lemma insert_rga_Some_commutes:
  assumes "i1 \<in> set xs" and "i2 \<in> set xs"
    and "e1 \<noteq> i2" and "e2 \<noteq> i1"
  shows "insert_rga (insert_rga xs (e1, Some i1)) (e2, Some i2) =
         insert_rga (insert_rga xs (e2, Some i2)) (e1, Some i1)"
  using assms proof (induction xs, simp)
  case (Cons a xs)
  then show ?case
    by (cases "a = i1"; cases "a = i2";
        auto simp add: insert_body_commutes insert_rga_insert_body_commute)
qed

lemma insert_rga_commutes:
  assumes "i2 \<noteq> Some e1" and "i1 \<noteq> Some e2"
  shows "insert_rga (insert_rga xs (e1, i1)) (e2, i2) =
         insert_rga (insert_rga xs (e2, i2)) (e1, i1)"
proof(cases i1)
  case None
  then show ?thesis
    using assms(1) insert_rga_None_commutes by (cases i2, fastforce, blast)
next
  case some_r1: (Some r1)
  then show ?thesis
  proof(cases i2)
    case None
    then show ?thesis
      using assms(2) insert_rga_None_commutes by fastforce
  next
    case some_r2: (Some r2)
    then show ?thesis
    proof(cases "r1 \<in> set xs \<and> r2 \<in> set xs")
      case True
      then show ?thesis
        using assms some_r1 some_r2 by (simp add: insert_rga_Some_commutes)
    next
      case False
      then show ?thesis
        using assms some_r1 some_r2
        by (metis insert_iff insert_rga_nonexistent insert_rga_set_ins)
    qed
  qed
qed

lemma insert_body_split:
  shows "\<exists>p s. xs = p @ s \<and> insert_body xs e = p @ e # s"
proof(induction xs, force)
  case (Cons a xs)
  then obtain p s where IH: "xs = p @ s \<and> insert_body xs e = p @ e # s"
    by blast
  then show "\<exists>p s. a # xs = p @ s \<and> insert_body (a # xs) e = p @ e # s"
  proof(cases "a < e")
    case True
    then have "a # xs = [] @ (a # p @ s) \<and> insert_body (a # xs) e = [] @ e # (a # p @ s)"
      by (simp add: IH)
    then show ?thesis by blast
  next
    case False
    then have "a # xs = (a # p) @ s \<and> insert_body (a # xs) e = (a # p) @ e # s"
      using IH by auto
    then show ?thesis by blast
  qed
qed

lemma insert_between_elements:
  assumes "xs = pre @ ref # suf"
    and "distinct xs"
    and "\<And>i. i \<in> set xs \<Longrightarrow> i < e"
  shows "insert_rga xs (e, Some ref) = pre @ ref # e # suf"
  using assms proof(induction xs arbitrary: pre, force)
  case (Cons a xs)
  then show "insert_rga (a # xs) (e, Some ref) = pre @ ref # e # suf"
  proof(cases pre)
    case pre_nil: Nil
    then have "a = ref"
      using Cons.prems(1) by auto
    then show ?thesis
      using Cons.prems pre_nil by (cases suf, auto)
  next
    case (Cons b pre')
    then have "insert_rga xs (e, Some ref) = pre' @ ref # e # suf"
      using Cons.IH Cons.prems by auto
    then show ?thesis
      using Cons.prems(1) Cons.prems(2) local.Cons by auto
  qed
qed

lemma insert_rga_after_ref:
  assumes "\<forall>x\<in>set as. a \<noteq> x"
    and "insert_body (cs @ ds) e = cs @ e # ds"
  shows "insert_rga (as @ a # cs @ ds) (e, Some a) = as @ a # cs @ e # ds"
  using assms by (induction as; auto)

subsection\<open>Lemmas about the \isa{rga-ops} predicate\<close>

definition rga_ops :: "('oid::{linorder} \<times> 'oid option) list \<Rightarrow> bool" where
  "rga_ops list \<equiv> crdt_ops list set_option"

lemma rga_ops_rem_last:
  assumes "rga_ops (xs @ [x])"
  shows "rga_ops xs"
  using assms crdt_ops_rem_last rga_ops_def by blast

lemma rga_ops_rem_penultimate:
  assumes "rga_ops (xs @ [(i1, r1), (i2, r2)])"
    and "\<And>r. r2 = Some r \<Longrightarrow> r \<noteq> i1"
  shows "rga_ops (xs @ [(i2, r2)])"
  using assms proof -
  have "crdt_ops (xs @ [(i2, r2)]) set_option"
    using assms crdt_ops_rem_penultimate rga_ops_def by fastforce
  thus "rga_ops (xs @ [(i2, r2)])"
    by (simp add: rga_ops_def)
qed

lemma rga_ops_ref_exists:
  assumes "rga_ops (pre @ (oid, Some ref) # suf)"
  shows "ref \<in> fst ` set pre"
proof -
  from assms have "crdt_ops (pre @ (oid, Some ref) # suf) set_option"
    by (simp add: rga_ops_def)
  moreover have "set_option (Some ref) = {ref}"
    by simp
  ultimately show "ref \<in> fst ` set pre"
    using crdt_ops_ref_exists by fastforce
qed

subsection\<open>Lemmas about the \isa{interp-rga} function\<close>

lemma interp_rga_tail_unfold:
  shows "interp_rga (xs@[x]) = insert_rga (interp_rga (xs)) x"
  by (clarsimp simp add: interp_rga_def)

lemma interp_rga_ids:
  assumes "rga_ops xs"
  shows "set (interp_rga xs) = set (map fst xs)"
  using assms proof(induction xs rule: List.rev_induct)
  case Nil
  then show "set (interp_rga []) = set (map fst [])"
    by (simp add: interp_rga_def)
next
  case (snoc x xs)
  hence IH: "set (interp_rga xs) = set (map fst xs)"
    using rga_ops_rem_last by blast
  obtain xi xr where x_pair: "x = (xi, xr)" by force
  then show "set (interp_rga (xs @ [x])) = set (map fst (xs @ [x]))"
  proof(cases xr)
    case None
    then show ?thesis
      using IH x_pair by (clarsimp simp add: interp_rga_def)
  next
    case (Some r)
    moreover from this have "r \<in> set (interp_rga xs)"
      using IH rga_ops_ref_exists by (metis x_pair list.set_map snoc.prems)
    ultimately have "set (interp_rga (xs @ [(xi, xr)])) = insert xi (set (interp_rga xs))"
      by (simp add: insert_rga_set_ins interp_rga_tail_unfold)
    then show "set (interp_rga (xs @ [x])) = set (map fst (xs @ [x]))"
      using IH x_pair by auto
  qed
qed

lemma interp_rga_distinct:
  assumes "rga_ops xs"
  shows "distinct (interp_rga xs)"
  using assms proof(induction xs rule: List.rev_induct)
  case Nil
  then show "distinct (interp_rga [])" by (simp add: interp_rga_def)
next
  case (snoc x xs)
  hence IH: "distinct (interp_rga xs)"
    using rga_ops_rem_last by blast
  moreover obtain xi xr where x_pair: "x = (xi, xr)"
    by force
  moreover from this have "xi \<notin> set (interp_rga xs)"
    using interp_rga_ids crdt_ops_unique_last rga_ops_rem_last
    by (metis rga_ops_def snoc.prems)
  moreover have "\<exists>pre suf. interp_rga xs = pre@suf \<and>
           insert_rga (interp_rga xs) (xi, xr) = pre @ xi # suf"
  proof -
    have "\<And>r. r \<in> set_option xr \<Longrightarrow> r \<in> set (map fst xs)"
      using crdt_ops_ref_exists rga_ops_def snoc.prems x_pair by fastforce
    hence "xr = None \<or> (\<exists>r. xr = Some r \<and> r \<in> set (map fst xs))"
      using option.set_sel by blast
    hence "xr = None \<or> (\<exists>r. xr = Some r \<and> r \<in> set (interp_rga xs))"
      using interp_rga_ids rga_ops_rem_last snoc.prems by blast
    thus ?thesis
      using IH insert_rga_preserves_order by blast
  qed
  ultimately show "distinct (interp_rga (xs @ [x]))"
    by (metis Un_iff disjoint_insert(1) distinct.simps(2) distinct_append
        interp_rga_tail_unfold list.simps(15) set_append)
qed

subsection\<open>Proof that RGA satisfies the list specification\<close>

lemma final_insert:
  assumes "set (xs @ [x]) = set (ys @ [x])"
    and "rga_ops (xs @ [x])"
    and "insert_ops (ys @ [x])"
    and "interp_rga xs = interp_ins ys"
  shows "interp_rga (xs @ [x]) = interp_ins (ys @ [x])"
proof -
  obtain oid ref where x_pair: "x = (oid, ref)" by force
  have "distinct (xs @ [x])" and "distinct (ys @ [x])"
    using assms crdt_ops_distinct spec_ops_distinct rga_ops_def insert_ops_def by blast+
  then have "set xs = set ys"
    using assms(1) by force
  have oid_greatest: "\<And>i. i \<in> set (interp_rga xs) \<Longrightarrow> i < oid"
  proof -
    have "\<And>i. i \<in> set (map fst ys) \<Longrightarrow> i < oid"
      using assms(3) by (simp add: spec_ops_id_inc x_pair insert_ops_def)
    hence "\<And>i. i \<in> set (map fst xs) \<Longrightarrow> i < oid"
      using \<open>set xs = set ys\<close> by auto
    thus "\<And>i. i \<in> set (interp_rga xs) \<Longrightarrow> i < oid"
      using assms(2) interp_rga_ids rga_ops_rem_last by blast
  qed
  thus "interp_rga (xs @ [x]) = interp_ins (ys @ [x])"
  proof(cases ref)
    case None
    moreover from this have "insert_rga (interp_rga xs) (oid, ref) = oid # interp_rga xs"
      using oid_greatest hd_in_set insert_body.elims insert_body.simps(1)
        insert_rga.simps(1) list.sel(1) by metis
    ultimately show "interp_rga (xs @ [x]) = interp_ins (ys @ [x])"
      using assms(4) by (simp add: interp_ins_tail_unfold interp_rga_tail_unfold x_pair)
  next
    case (Some r)
    have "\<exists>as bs. interp_rga xs = as @ r # bs"
    proof -
      have "r \<in> set (map fst xs)"
        using assms(2) Some by (simp add: rga_ops_ref_exists x_pair)
      hence "r \<in> set (interp_rga xs)"
        using assms(2) interp_rga_ids rga_ops_rem_last by blast
      thus ?thesis by (simp add: split_list)
    qed
    from this obtain as bs where as_bs: "interp_rga xs = as @ r # bs" by force
    hence "distinct (as @ r # bs)"
      by (metis assms(2) interp_rga_distinct rga_ops_rem_last)
    hence "insert_rga (as @ r # bs) (oid, Some r) = as @ r # oid # bs"
      by (metis as_bs insert_between_elements oid_greatest)
    moreover have "insert_spec (as @ r # bs) (oid, Some r) = as @ r # oid # bs"
      by (meson \<open>distinct (as @ r # bs)\<close> insert_after_ref)
    ultimately show "interp_rga (xs @ [x]) = interp_ins (ys @ [x])"
      by (metis assms(4) Some as_bs interp_ins_tail_unfold interp_rga_tail_unfold x_pair)
  qed
qed

lemma interp_rga_reorder:
  assumes "rga_ops (pre @ suf @ [(oid, ref)])"
    and "\<And>i r. (i, Some r) \<in> set suf \<Longrightarrow> r \<noteq> oid"
    and "\<And>r. ref = Some r \<Longrightarrow> r \<notin> fst ` set suf"
  shows "interp_rga (pre @ (oid, ref) # suf) = interp_rga (pre @ suf @ [(oid, ref)])"
  using assms proof(induction suf rule: List.rev_induct)
  case Nil
  then show ?case by simp
next
  case (snoc x xs)
  have ref_not_x: "\<And>r. ref = Some r \<Longrightarrow> r \<noteq> fst x" using snoc.prems(3) by auto
  have IH: "interp_rga (pre @ (oid, ref) # xs) = interp_rga (pre @ xs @ [(oid, ref)])"
  proof -
    have "rga_ops ((pre @ xs) @ [x] @ [(oid, ref)])"
      using snoc.prems(1) by auto
    moreover have "\<And>r. ref = Some r \<Longrightarrow> r \<noteq> fst x"
      by (simp add: ref_not_x)
    ultimately have "rga_ops ((pre @ xs) @ [(oid, ref)])"
      using rga_ops_rem_penultimate
      by (metis (no_types, lifting) Cons_eq_append_conv prod.collapse)
    thus ?thesis using snoc by force
  qed
  obtain xi xr where x_pair: "x = (xi, xr)" by force
  have "interp_rga (pre @ (oid, ref) # xs @ [(xi, xr)]) =
        insert_rga (interp_rga (pre @ xs @ [(oid, ref)])) (xi, xr)"
    using IH interp_rga_tail_unfold by (metis append.assoc append_Cons)
  moreover have "... = insert_rga (insert_rga (interp_rga (pre @ xs)) (oid, ref)) (xi, xr)"
    using interp_rga_tail_unfold by (metis append_assoc)
  moreover have "... = insert_rga (insert_rga (interp_rga (pre @ xs)) (xi, xr)) (oid, ref)"
  proof -
    have "\<And>xrr. xr = Some xrr \<Longrightarrow> xrr \<noteq> oid"
      using x_pair snoc.prems(2) by auto
    thus ?thesis
      using insert_rga_commutes ref_not_x by (metis fst_conv x_pair)
  qed
  moreover have "... = interp_rga (pre @ xs @ [x] @ [(oid, ref)])"
    by (metis append_assoc interp_rga_tail_unfold x_pair)
  ultimately show "interp_rga (pre @ (oid, ref) # xs @ [x]) =
                   interp_rga (pre @ (xs @ [x]) @ [(oid, ref)])"
    by (simp add: x_pair)
qed

lemma rga_spec_equal:
  assumes "set xs = set ys"
    and "insert_ops xs"
    and "rga_ops ys"
  shows "interp_ins xs = interp_rga ys"
  using assms proof(induction xs arbitrary: ys rule: rev_induct)
  case Nil
  then show ?case by (simp add: interp_rga_def interp_ins_def)
next
  case (snoc x xs)
  hence "x \<in> set ys"
    by (metis last_in_set snoc_eq_iff_butlast)
  from this obtain pre suf where ys_split: "ys = pre @ [x] @ suf"
    using split_list_first by fastforce
  have IH: "interp_ins xs = interp_rga (pre @ suf)"
  proof -
    have "crdt_ops (pre @ suf) set_option"
    proof -
      have "crdt_ops (pre @ [x] @ suf) set_option"
        using rga_ops_def snoc.prems(3) ys_split by blast
      thus "crdt_ops (pre @ suf) set_option"
        using crdt_ops_rem_spec snoc.prems ys_split insert_ops_def by blast
    qed
    hence "rga_ops (pre @ suf)"
      using rga_ops_def by blast
    moreover have "set xs = set (pre @ suf)"
      by (metis append_set_rem_last crdt_ops_distinct insert_ops_def rga_ops_def
          snoc.prems spec_ops_distinct ys_split)
    ultimately show ?thesis
      using insert_ops_rem_last ys_split snoc by metis
  qed
  have valid_rga: "rga_ops (pre @ suf @ [x])"
  proof -
    have "crdt_ops (pre @ suf @ [x]) set_option"
      using snoc.prems ys_split
      by (simp add: crdt_ops_reorder_spec insert_ops_def rga_ops_def)
    thus "rga_ops (pre @ suf @ [x])"
      by (simp add: rga_ops_def)
  qed
  have "interp_ins (xs @ [x]) = interp_rga (pre @ suf @ [x])"
  proof -
    have "set (xs @ [x]) = set (pre @ suf @ [x])"
      using snoc.prems(1) ys_split by auto
    thus ?thesis
      using IH snoc.prems(2) valid_rga final_insert append_assoc by metis
  qed
  moreover have "... = interp_rga (pre @ [x] @ suf)"
  proof -
    obtain oid ref where x_pair: "x = (oid, ref)"
      by force
    have "\<And>op2 r. op2 \<in> snd ` set suf \<Longrightarrow> r \<in> set_option op2 \<Longrightarrow> r \<noteq> oid"
      using snoc.prems
      by (simp add: crdt_ops_independent_suf insert_ops_def rga_ops_def x_pair ys_split)
    hence "\<And>i r. (i, Some r) \<in> set suf \<Longrightarrow> r \<noteq> oid"
      by fastforce
    moreover have "\<And>r. ref = Some r \<Longrightarrow> r \<notin> fst ` set suf"
      using crdt_ops_no_future_ref snoc.prems(3) x_pair ys_split
      by (metis option.set_intros rga_ops_def)
    ultimately show "interp_rga (pre @ suf @ [x]) = interp_rga (pre @ [x] @ suf)"
      using interp_rga_reorder valid_rga x_pair by force
  qed
  ultimately show "interp_ins (xs @ [x]) = interp_rga ys"
    by (simp add: ys_split)
qed

lemma insert_ops_exist:
  assumes "rga_ops xs"
  shows "\<exists>ys. set xs = set ys \<and> insert_ops ys"
  using assms by (simp add: crdt_ops_spec_ops_exist insert_ops_def rga_ops_def)

theorem rga_meets_spec:
  assumes "rga_ops xs"
  shows "\<exists>ys. set ys = set xs \<and> insert_ops ys \<and> interp_ins ys = interp_rga xs"
  using assms rga_spec_equal insert_ops_exist by metis

end


(*  Author:      Norbert Schirmer
    Maintainer:  Norbert Schirmer, norbert.schirmer at web de
    License:     LGPL
*)

(*  Title:      HeapList.thy
    Author:     Norbert Schirmer, TU Muenchen

Copyright (C) 2004-2008 Norbert Schirmer
Some rights reserved, TU Muenchen

This library is free software; you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as
published by the Free Software Foundation; either version 2.1 of the
License, or (at your option) any later version.

This library is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Lesser General Public License for more details.

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307
USA
*)

section {* Paths and Lists in the Heap *}
theory HeapList
imports Simpl_Heap
begin

text {* Adapted from 'HOL/Hoare/Heap.thy'. *}

subsection "Paths in The Heap"

primrec
 Path :: "ref \<Rightarrow> (ref \<Rightarrow> ref) \<Rightarrow> ref \<Rightarrow>  ref list  \<Rightarrow> bool"
where
"Path x h y [] = (x = y)" |
"Path x h y (p#ps) = (x = p \<and> x \<noteq> Null \<and> Path (h x) h y ps)"

lemma Path_Null_iff [iff]: "Path Null h y xs  = (xs = [] \<and> y = Null)"
apply(case_tac xs)
apply fastforce
apply fastforce
done

lemma Path_not_Null_iff [simp]: "p\<noteq>Null \<Longrightarrow>
  Path p h q as = (as = [] \<and> q = p  \<or>  (\<exists>ps. as = p#ps \<and> Path (h p) h q ps ))"
apply(case_tac as)
apply fastforce
apply fastforce
done

lemma Path_append [simp]:
  "\<And>p. Path p f q (as@bs)  = (\<exists>y. Path p f y as \<and> Path y f q bs)"
by(induct as, simp+)

lemma notin_Path_update[simp]:
 "\<And>p. u \<notin> set ps \<Longrightarrow> Path p (f(u := v)) q ps  = Path p f q ps "
by(induct ps, simp, simp add:eq_sym_conv)

lemma Path_upd_same [simp]:
  "Path p (f(p:=p)) q qs =
      ((p=Null \<and> q=Null \<and> qs = []) \<or> (p\<noteq>Null \<and> q=p \<and> (\<forall>x\<in>set qs. x=p)))"
by (induct qs) auto

text {* @{thm[source] Path_upd_same} prevents
@{term "p\<noteq>Null \<Longrightarrow> Path p (f(p:=p)) q qs = X"} from looping, because of
@{thm[source] Path_not_Null_iff} and @{thm[source]fun_upd_apply}.
 *}

lemma notin_Path_updateI [intro]:
 "\<lbrakk>Path p h q ps ; r \<notin> set ps\<rbrakk> \<Longrightarrow> Path p (h(r := y)) q ps "
by simp

lemma Path_update_new [simp]: "\<lbrakk>set ps \<subseteq> set alloc\<rbrakk>
     \<Longrightarrow> Path p (f(new (set alloc) := x)) q ps  = Path p f q ps "
  by (rule notin_Path_update) fastforce

lemma Null_notin_Path [simp,intro]:
"\<And>p. Path p f q ps \<Longrightarrow> Null \<notin> set ps"
by(induct ps) auto

lemma Path_snoc:
 "\<lbrakk>Path p (f(a := q)) a as ; a\<noteq>Null\<rbrakk> \<Longrightarrow> Path p (f(a := q)) q (as @ [a])"
by simp

subsection "Lists on The Heap"

subsubsection "Relational Abstraction"

definition
 List :: "ref \<Rightarrow> (ref \<Rightarrow> ref) \<Rightarrow> ref list \<Rightarrow> bool" where
"List p h ps = Path p h Null ps "

lemma List_empty [simp]: "List p h [] = (p = Null)"
by(simp add:List_def)

lemma List_cons [simp]: "List p h (a#ps) = (p = a \<and> p\<noteq>Null \<and> List (h p) h ps)"
by(simp add:List_def)

lemma List_Null [simp]: "List Null h ps = (ps = [])"
by(case_tac ps, simp_all)

lemma List_not_Null [simp]: "p\<noteq>Null \<Longrightarrow>
  List p h as = (\<exists>ps. as = p#ps \<and> List (h p) h ps)"
by(case_tac as, simp_all, fast)

lemma Null_notin_List [simp,intro]: "\<And>p. List p h ps \<Longrightarrow> Null \<notin> set ps"
by (simp add : List_def)

lemma List_upd_same_lemma: "\<And>p.  p \<noteq> Null \<Longrightarrow> \<not> List p (h(p := p)) ps"
apply (induct ps)
apply  simp
apply (simp (no_asm_simp) del: fun_upd_apply)
apply (simp (no_asm_simp) only: fun_upd_apply refl if_True)
apply blast
done

lemma List_upd_same [simp]: "List p (h(p:=p)) ps = (p = Null \<and> ps = [])"
apply (cases "p=Null")
apply  simp
apply (fast dest: List_upd_same_lemma)
done

text {* @{thm[source] List_upd_same} prevents
@{term "p\<noteq>Null \<Longrightarrow> List p (h(p:=p)) as = X"} from looping, because of
@{thm[source] List_not_Null} and @{thm[source] fun_upd_apply}.
 *}

lemma  List_update_new [simp]: "\<lbrakk>set ps \<subseteq> set alloc\<rbrakk>
     \<Longrightarrow> List p (h(new (set alloc) := x)) ps = List p h ps"
by (rule notin_List_update) fastforce

lemma List_updateI [intro]:
 "\<lbrakk>List p h ps; q \<notin> set ps\<rbrakk> \<Longrightarrow> List p (h(q := y)) ps"
by simp

lemma List_unique: "\<And>p bs. List p h as \<Longrightarrow> List p h bs \<Longrightarrow> as = bs"
by(induct as, simp, clarsimp)

lemma List_unique1: "List p h as \<Longrightarrow> \<exists>!as. List p h as"
by(blast intro:List_unique)

lemma List_app: "\<And>p. List p h (as@bs) = (\<exists>y. Path p h y as \<and> List y h bs)"
by(induct as, simp, clarsimp)

lemma List_hd_not_in_tl[simp]: "List (h p) h ps \<Longrightarrow> p \<notin> set ps"
apply (clarsimp simp add:in_set_conv_decomp)
apply(frule List_app[THEN iffD1])
apply(fastforce dest: List_unique)
done

lemma List_distinct[simp]: "\<And>p. List p h ps \<Longrightarrow> distinct ps"
apply(induct ps, simp)
apply(fastforce dest:List_hd_not_in_tl)
done

lemma heap_eq_List_eq:
  "\<And>p. \<forall>x \<in> set ps. h x = g x \<Longrightarrow> List p h ps = List p g ps"
  by (induct ps) auto

lemma heap_eq_ListI:
  assumes list: "List p h ps"
  assumes hp_eq: "\<forall>x \<in> set ps. h x = g x"
  shows "List p g ps"
  using list
  by (simp add: heap_eq_List_eq [OF hp_eq])

lemma heap_eq_ListI1:
  assumes list: "List p h ps"
  assumes hp_eq: "\<forall>x \<in> set ps. g x = h x"
  shows "List p g ps"
  using list
  by (simp add: heap_eq_List_eq [OF hp_eq])

text {* The following lemmata are usefull for the simplifier to instantiate
bound variables in the assumptions resp. conclusion, using the uniqueness
of the List predicate *}

lemma conj_impl_simp: "(P \<and> Q \<longrightarrow> K) = (P \<longrightarrow> Q \<longrightarrow> K)"
by auto

lemma  List_unique_all_impl_simp [simp]:
 "List p h ps \<Longrightarrow> (\<forall>ps. List p h ps \<longrightarrow> P ps) = P ps"
by (auto dest: List_unique)

(*
lemma  List_unique_all_impl_simp1 [simp]:
 "List p h ps \<Longrightarrow> (\<forall>ps. Q ps \<longrightarrow> List p h ps \<longrightarrow> P ps) = Q ps \<longrightarrow> P ps"
by (auto dest: List_unique)
*)
lemma List_unique_ex_conj_simp [simp]:
"List p h ps \<Longrightarrow> (\<exists>ps. List p h ps \<and> P ps) = P ps"
by (auto dest: List_unique)

subsection "Functional abstraction"

definition
 islist :: "ref \<Rightarrow> (ref \<Rightarrow> ref) \<Rightarrow> bool" where
"islist p h = (\<exists>ps. List p h ps)"

definition
 list :: "ref \<Rightarrow> (ref \<Rightarrow> ref) \<Rightarrow> ref list" where
"list p h = (THE ps. List p h ps)"

lemma List_conv_islist_list: "List p h ps = (islist p h \<and> ps = list p h)"
apply(simp add:islist_def list_def)
apply(rule iffI)
apply(rule conjI)
apply blast
apply(subst the1_equality)
  apply(erule List_unique1)
 apply assumption
apply(rule refl)
apply simp
apply (clarify)
apply (rule theI)
apply  assumption
by (rule List_unique)

lemma List_islist [intro]:
  "List p h ps \<Longrightarrow> islist p h"
  apply (simp add: List_conv_islist_list)
  done

lemma List_list:
  "List p h ps \<Longrightarrow> list p h = ps"
  apply (simp only: List_conv_islist_list)
  done

lemma [simp]: "p\<noteq>Null \<Longrightarrow> islist (h p) h = islist p h"
by(simp add:islist_def)

lemma [simp]: "list Null h = []"
by(simp add:list_def)

lemma list_Ref_conv[simp]:
 "\<lbrakk>islist (h p) h; p\<noteq>Null \<rbrakk> \<Longrightarrow> list p h = p # list (h p) h"
apply(insert List_not_Null[of _ h])
apply(fastforce simp:List_conv_islist_list)
done

lemma [simp]: "islist (h p) h \<Longrightarrow> p \<notin> set(list (h p) h)"
apply(insert List_hd_not_in_tl[of h])
apply(simp add:List_conv_islist_list)
done

lemma list_upd_conv[simp]:
 "islist p h \<Longrightarrow> y \<notin> set(list p h) \<Longrightarrow> list p (h(y := q)) = list p h"
apply(drule notin_List_update[of _ _ p h q])
apply(simp add:List_conv_islist_list)
done

lemma islist_upd[simp]:
 "islist p h \<Longrightarrow> y \<notin> set(list p h) \<Longrightarrow> islist p (h(y := q))"
apply(frule notin_List_update[of _ _ p h q])
apply(simp add:List_conv_islist_list)
done

lemma list_distinct[simp]: "islist p h \<Longrightarrow> distinct (list p h)"
apply (clarsimp simp add: list_def islist_def)
apply (frule List_unique1)
apply (drule (1) the1_equality)
apply simp
done

lemma Null_notin_list [simp,intro]: "islist p h \<Longrightarrow> Null \<notin> set (list p h)"
apply (clarsimp simp add: list_def islist_def)
apply (frule List_unique1)
apply (drule (1) the1_equality)
apply simp
done

end