Quelle  Linear_Temporal_Logic_on_Streams.thy   Sprache: Isabelle

(*  Title:      HOL/Library/Linear_Temporal_Logic_on_Streams.thy
    Author:     Andrei Popescu, TU Muenchen
    Author:     Dmitriy Traytel, TU Muenchen
*)

section ‹Linear Temporal Logic on Streams›

theory Linear_Temporal_Logic_on_Streams
  imports Stream Sublist Extended_Nat Infinite_Set
begin

section‹Preliminaries›

lemma shift_prefix:
assumes "xl @- xs = yl @- ys" and "length xl \ length yl"
shows "prefix xl yl"
using assms proof(induct xl arbitrary: yl xs ys)
  case (Cons x xl yl xs ys)
  thus ?case by (cases yl) auto
qed auto

lemma shift_prefix_cases:
assumes "xl @- xs = yl @- ys"
shows "prefix xl yl \ prefix yl xl"
using shift_prefix[OF assms]
by (cases "length xl \ length yl") (metis, metis assms nat_le_linear shift_prefix)


section‹Linear temporal logic›

text ‹Propositional connectives:›

abbreviation (input) IMPL (infix ‹impl› 60)
where "\ impl \ \ \ xs. \ xs \ \ xs"

abbreviation (input) OR (infix ‹or› 60)
where "\ or \ \ \ xs. \ xs \ \ xs"

abbreviation (input) AND (infix ‹aand› 60)
where "\ aand \ \ \ xs. \ xs \ \ xs"

abbreviation (input) not where "not \ \ \ xs. \ \ xs"

abbreviation (input) "true \ \ xs. True"

abbreviation (input) "false \ \ xs. False"

lemma impl_not_or: "\ impl \ = (not \) or \"
by blast

lemma not_or: "not (\ or \) = (not \) aand (not \)"
by blast

lemma not_aand: "not (\ aand \) = (not \) or (not \)"
by blast

lemma non_not[simp]: "not (not \) = \" by simp

text ‹Temporal (LTL) connectives:›

fun holds where "holds P xs \ P (shd xs)"
fun nxt where "nxt \ xs = \ (stl xs)"

definition "HLD s = holds (\x. x \ s)"

abbreviation HLD_nxt (infixr ‹⋅› 65) where
  "s \ P \ HLD s aand nxt P"

context
  notes [[inductive_internals]]
begin

inductive ev for φ where
base: "\ xs \ ev \ xs"
|
step: "ev \ (stl xs) \ ev \ xs"

coinductive alw for φ where
alw: "\\ xs; alw \ (stl xs)\ \ alw \ xs"

🍋 ‹weak until:›
coinductive UNTIL (infix ‹until› 60) for φ ψ where
base: "\ xs \ (\ until \) xs"
|
step: "\\ xs; (\ until \) (stl xs)\ \ (\ until \) xs"

end

lemma holds_mono:
assumes holds: "holds P xs" and 0: "\ x. P x \ Q x"
shows "holds Q xs"
using assms by auto

lemma holds_aand:
"(holds P aand holds Q) steps \ holds (\ step. P step \ Q step) steps" by auto

lemma HLD_iff: "HLD s \ \ shd \ \ s"
  by (simp add: HLD_def)

lemma HLD_Stream[simp]: "HLD X (x ## \) \ x \ X"
  by (simp add: HLD_iff)

lemma nxt_mono:
assumes nxt: "nxt \ xs" and 0: "\ xs. \ xs \ \ xs"
shows "nxt \ xs"
using assms by auto

declare ev.intros[intro]
declare alw.cases[elim]

lemma ev_induct_strong[consumes 1, case_names base step]:
  "ev \ x \ (\xs. \ xs \ P xs) \ (\xs. ev \ (stl xs) \ \ \ xs \ P (stl xs) \ P xs) \ P x"
  by (induct rule: ev.induct) auto

lemma alw_coinduct[consumes 1, case_names alw stl]:
  "X x \ (\x. X x \ \ x) \ (\x. X x \ \ alw \ (stl x) \ X (stl x)) \ alw \ x"
  using alw.coinduct[of X x φ] by auto

lemma ev_mono:
assumes ev: "ev \ xs" and 0: "\ xs. \ xs \ \ xs"
shows "ev \ xs"
using ev by induct (auto simp: 0)

lemma alw_mono:
assumes alw: "alw \ xs" and 0: "\ xs. \ xs \ \ xs"
shows "alw \ xs"
using alw by coinduct (auto simp: 0)

lemma until_monoL:
assumes until: "(\1 until \) xs" and 0: "\ xs. \1 xs \ \2 xs"
shows "(\2 until \) xs"
using until by coinduct (auto elim: UNTIL.cases simp: 0)

lemma until_monoR:
assumes until: "(\ until \1) xs" and 0: "\ xs. \1 xs \ \2 xs"
shows "(\ until \2) xs"
using until by coinduct (auto elim: UNTIL.cases simp: 0)

lemma until_mono:
assumes until: "(\1 until \1) xs" and
0: "\ xs. \1 xs \ \2 xs" "\ xs. \1 xs \ \2 xs"
shows "(\2 until \2) xs"
using until by coinduct (auto elim: UNTIL.cases simp: 0)

lemma until_false: "\ until false = alw \"
proof-
  {fix xs assume "(\ until false) xs" hence "alw \ xs"
   by coinduct (auto elim: UNTIL.cases)
  }
  moreover
  {fix xs assume "alw \ xs" hence "(\ until false) xs"
   by coinduct auto
  }
  ultimately show ?thesis by blast
qed

lemma ev_nxt: "ev \ = (\ or nxt (ev \))"
by (rule ext) (metis ev.simps nxt.simps)

lemma alw_nxt: "alw \ = (\ aand nxt (alw \))"
by (rule ext) (metis alw.simps nxt.simps)

lemma ev_ev[simp]: "ev (ev \) = ev \"
proof-
  {fix xs
   assume "ev (ev \) xs" hence "ev \ xs"
   by induct auto
  }
  thus ?thesis by auto
qed

lemma alw_alw[simp]: "alw (alw \) = alw \"
proof-
  {fix xs
   assume "alw \ xs" hence "alw (alw \) xs"
   by coinduct auto
  }
  thus ?thesis by auto
qed

lemma ev_shift:
assumes "ev \ xs"
shows "ev \ (xl @- xs)"
using assms by (induct xl) auto

lemma ev_imp_shift:
assumes "ev \ xs"  shows "\ xl xs2. xs = xl @- xs2 \ \ xs2"
using assms by induct (metis shift.simps(1), metis shift.simps(2) stream.collapse)+

lemma alw_ev_shift: "alw \ xs1 \ ev (alw \) (xl @- xs1)"
by (auto intro: ev_shift)

lemma alw_shift:
assumes "alw \ (xl @- xs)"
shows "alw \ xs"
using assms by (induct xl) auto

lemma ev_ex_nxt:
assumes "ev \ xs"
shows "\ n. (nxt ^^ n) \ xs"
using assms proof induct
  case (base xs) thus ?case by (intro exI[of _ 0]) auto
next
  case (step xs)
  then obtain n where "(nxt ^^ n) \ (stl xs)" by blast
  thus ?case by (intro exI[of _ "Suc n"]) (metis funpow.simps(2) nxt.simps o_def)
qed

lemma alw_sdrop:
assumes "alw \ xs"  shows "alw \ (sdrop n xs)"
by (metis alw_shift assms stake_sdrop)

lemma nxt_sdrop: "(nxt ^^ n) \ xs \ \ (sdrop n xs)"
by (induct n arbitrary: xs) auto

definition "wait \ xs \ LEAST n. (nxt ^^ n) \ xs"

lemma nxt_wait:
assumes "ev \ xs"  shows "(nxt ^^ (wait \ xs)) \ xs"
unfolding wait_def using ev_ex_nxt[OF assms] by(rule LeastI_ex)

lemma nxt_wait_least:
assumes ev: "ev \ xs" and nxt: "(nxt ^^ n) \ xs"  shows "wait \ xs \ n"
unfolding wait_def using ev_ex_nxt[OF ev] by (metis Least_le nxt)

lemma sdrop_wait:
assumes "ev \ xs"  shows "\ (sdrop (wait \ xs) xs)"
using nxt_wait[OF assms] unfolding nxt_sdrop .

lemma sdrop_wait_least:
assumes ev: "ev \ xs" and nxt: "\ (sdrop n xs)"  shows "wait \ xs \ n"
using assms nxt_wait_least unfolding nxt_sdrop by auto

lemma nxt_ev: "(nxt ^^ n) \ xs \ ev \ xs"
by (induct n arbitrary: xs) auto

lemma not_ev: "not (ev \) = alw (not \)"
proof(rule ext, safe)
  fix xs assume "not (ev \) xs" thus "alw (not \) xs"
  by (coinduct) auto
next
  fix xs assume "ev \ xs" and "alw (not \) xs" thus False
  by (induct) auto
qed

lemma not_alw: "not (alw \) = ev (not \)"
proof-
  have "not (alw \) = not (alw (not (not \)))" by simp
  also have "... = ev (not \)" unfolding not_ev[symmetric] by simp
  finally show ?thesis .
qed

lemma not_ev_not[simp]: "not (ev (not \)) = alw \"
unfolding not_ev by simp

lemma not_alw_not[simp]: "not (alw (not \)) = ev \"
unfolding not_alw by simp

lemma alw_ev_sdrop:
assumes "alw (ev \) (sdrop m xs)"
shows "alw (ev \) xs"
using assms
by coinduct (metis alw_nxt ev_shift funpow_swap1 nxt.simps nxt_sdrop stake_sdrop)

lemma ev_alw_imp_alw_ev:
assumes "ev (alw \) xs"  shows "alw (ev \) xs"
using assms by induct (metis (full_types) alw_mono ev.base, metis alw alw_nxt ev.step)

lemma alw_aand: "alw (\ aand \) = alw \ aand alw \"
proof-
  {fix xs assume "alw (\ aand \) xs" hence "(alw \ aand alw \) xs"
   by (auto elim: alw_mono)
  }
  moreover
  {fix xs assume "(alw \ aand alw \) xs" hence "alw (\ aand \) xs"
   by coinduct auto
  }
  ultimately show ?thesis by blast
qed

lemma ev_or: "ev (\ or \) = ev \ or ev \"
proof-
  {fix xs assume "(ev \ or ev \) xs" hence "ev (\ or \) xs"
   by (auto elim: ev_mono)
  }
  moreover
  {fix xs assume "ev (\ or \) xs" hence "(ev \ or ev \) xs"
   by induct auto
  }
  ultimately show ?thesis by blast
qed

lemma ev_alw_aand:
assumes φ: "ev (alw \) xs" and ψ: "ev (alw \) xs"
shows "ev (alw (\ aand \)) xs"
proof-
  obtain xl xs1 where xs1: "xs = xl @- xs1" and φφ: "alw \ xs1"
  using φ by (metis ev_imp_shift)
  moreover obtain yl ys1 where xs2: "xs = yl @- ys1" and ψψ: "alw \ ys1"
  using ψ by (metis ev_imp_shift)
  ultimately have 0: "xl @- xs1 = yl @- ys1" by auto
  hence "prefix xl yl \ prefix yl xl" using shift_prefix_cases by auto
  thus ?thesis proof
    assume "prefix xl yl"
    then obtain yl1 where yl: "yl = xl @ yl1" by (elim prefixE)
    have xs1': "xs1 = yl1 @- ys1" using 0 unfolding yl by simp
    have "alw \ ys1" using φφ unfolding xs1' by (metis alw_shift)
    hence "alw (\ aand \) ys1" using ψψ unfolding alw_aand by auto
    thus ?thesis unfolding xs2 by (auto intro: alw_ev_shift)
  next
    assume "prefix yl xl"
    then obtain xl1 where xl: "xl = yl @ xl1" by (elim prefixE)
    have ys1': "ys1 = xl1 @- xs1" using 0 unfolding xl by simp
    have "alw \ xs1" using ψψ unfolding ys1' by (metis alw_shift)
    hence "alw (\ aand \) xs1" using φφ unfolding alw_aand by auto
    thus ?thesis unfolding xs1 by (auto intro: alw_ev_shift)
  qed
qed

lemma ev_alw_alw_impl:
assumes "ev (alw \) xs" and "alw (alw \ impl ev \) xs"
shows "ev \ xs"
using assms by induct auto

lemma ev_alw_stl[simp]: "ev (alw \) (stl x) \ ev (alw \) x"
by (metis (full_types) alw_nxt ev_nxt nxt.simps)

lemma alw_alw_impl_ev:
"alw (alw \ impl ev \) = (ev (alw \) impl alw (ev \))" (is "?A = ?B")
proof-
  {fix xs assume "?A xs \ ev (alw \) xs" hence "alw (ev \) xs"
    by coinduct (auto elim: ev_alw_alw_impl)
  }
  moreover
  {fix xs assume "?B xs" hence "?A xs"
   by coinduct auto
  }
  ultimately show ?thesis by blast
qed

lemma ev_alw_impl:
assumes "ev \ xs" and "alw (\ impl \) xs"  shows "ev \ xs"
using assms by induct auto

lemma ev_alw_impl_ev:
assumes "ev \ xs" and "alw (\ impl ev \) xs"  shows "ev \ xs"
using ev_alw_impl[OF assms] by simp

lemma alw_mp:
assumes "alw \ xs" and "alw (\ impl \) xs"
shows "alw \ xs"
proof-
  {assume "alw \ xs \ alw (\ impl \) xs" hence ?thesis
   by coinduct auto
  }
  thus ?thesis using assms by auto
qed

lemma all_imp_alw:
assumes "\ xs. \ xs"  shows "alw \ xs"
proof-
  {assume "\ xs. \ xs"
   hence ?thesis by coinduct auto
  }
  thus ?thesis using assms by auto
qed

lemma alw_impl_ev_alw:
assumes "alw (\ impl ev \) xs"
shows "alw (ev \ impl ev \) xs"
using assms by coinduct (auto dest: ev_alw_impl)

lemma ev_holds_sset:
"ev (holds P) xs \ (\ x \ sset xs. P x)" (is "?L \ ?R")
proof safe
  assume ?L thus ?R by induct (metis holds.simps stream.set_sel(1), metis stl_sset)
next
  fix x assume "x \ sset xs" "P x"
  thus ?L by (induct rule: sset_induct) (simp_all add: ev.base ev.step)
qed

text ‹LTL as a program logic:›
lemma alw_invar:
assumes "\ xs" and "alw (\ impl nxt \) xs"
shows "alw \ xs"
proof-
  {assume "\ xs \ alw (\ impl nxt \) xs" hence ?thesis
   by coinduct auto
  }
  thus ?thesis using assms by auto
qed

lemma variance:
assumes 1: "\ xs" and 2: "alw (\ impl (\ or nxt \)) xs"
shows "(alw \ or ev \) xs"
proof-
  {assume "\ ev \ xs" hence "alw (not \) xs" unfolding not_ev[symmetric] .
   moreover have "alw (not \ impl (\ impl nxt \)) xs"
   using 2 by coinduct auto
   ultimately have "alw (\ impl nxt \) xs" by(auto dest: alw_mp)
   with 1 have "alw \ xs" by(rule alw_invar)
  }
  thus ?thesis by blast
qed

lemma ev_alw_imp_nxt:
assumes e: "ev \ xs" and a: "alw (\ impl (nxt \)) xs"
shows "ev (alw \) xs"
proof-
  obtain xl xs1 where xs: "xs = xl @- xs1" and φ: "\ xs1"
  using e by (metis ev_imp_shift)
  have "\ xs1 \ alw (\ impl (nxt \)) xs1" using a φ unfolding xs by (metis alw_shift)
  hence "alw \ xs1" by(coinduct xs1 rule: alw.coinduct) auto
  thus ?thesis unfolding xs by (auto intro: alw_ev_shift)
qed


inductive ev_at :: "('a stream \ bool) \ nat \ 'a stream \ bool" for P :: "'a stream \ bool" where
  base: "P \ \ ev_at P 0 \"
| step:"\ P \ \ ev_at P n (stl \) \ ev_at P (Suc n) \"

inductive_simps ev_at_0[simp]: "ev_at P 0 \"
inductive_simps ev_at_Suc[simp]: "ev_at P (Suc n) \"

lemma ev_at_imp_snth: "ev_at P n \ \ P (sdrop n \)"
  by (induction n arbitrary: ψ) auto

lemma ev_at_HLD_imp_snth: "ev_at (HLD X) n \ \ \ !! n \ X"
  by (auto dest!: ev_at_imp_snth simp: HLD_iff)

lemma ev_at_HLD_single_imp_snth: "ev_at (HLD {x}) n \ \ \ !! n = x"
  by (drule ev_at_HLD_imp_snth) simp

lemma ev_at_unique: "ev_at P n \ \ ev_at P m \ \ n = m"
proof (induction arbitrary: m rule: ev_at.induct)
  case (base ψ) then show ?case
    by (simp add: ev_at.simps[of _ _ ψ])
next
  case (step ψ n) from step.prems step.hyps step.IH[of "m - 1"] show ?case
    by (auto simp add: ev_at.simps[of _ _ ψ])
qed

lemma ev_iff_ev_at: "ev P \ \ (\n. ev_at P n \)"
proof
  assume "ev P \" then show "\n. ev_at P n \"
    by (induction rule: ev_induct_strong) (auto intro: ev_at.intros)
next
  assume "\n. ev_at P n \"
  then obtain n where "ev_at P n \"
    by auto
  then show "ev P \"
    by induction auto
qed

lemma ev_at_shift: "ev_at (HLD X) i (stake (Suc i) \ @- \' :: 's stream) \ ev_at (HLD X) i \"
  by (induction i arbitrary: ψ) (auto simp: HLD_iff)

lemma ev_iff_ev_at_unique: "ev P \ \ (\!n. ev_at P n \)"
  by (auto intro: ev_at_unique simp: ev_iff_ev_at)

lemma alw_HLD_iff_streams: "alw (HLD X) \ \ \ \ streams X"
proof
  assume "alw (HLD X) \" then show "\ \ streams X"
  proof (coinduction arbitrary: ψ)
    case (streams ψ) then show ?case by (cases ψ) auto
  qed
next
  assume "\ \ streams X" then show "alw (HLD X) \"
  proof (coinduction arbitrary: ψ)
    case (alw ψ) then show ?case by (cases ψ) auto
  qed
qed

lemma not_HLD: "not (HLD X) = HLD (- X)"
  by (auto simp: HLD_iff)

lemma not_alw_iff: "\ (alw P \) \ ev (not P) \"
  using not_alw[of P] by (simp add: fun_eq_iff)

lemma not_ev_iff: "\ (ev P \) \ alw (not P) \"
  using not_alw_iff[of "not P" ψ, symmetric]  by simp

lemma ev_Stream: "ev P (x ## s) \ P (x ## s) \ ev P s"
  by (auto elim: ev.cases)

lemma alw_ev_imp_ev_alw:
  assumes "alw (ev P) \" shows "ev (P aand alw (ev P)) \"
proof -
  have "ev P \" using assms by auto
  from this assms show ?thesis
    by induct auto
qed

lemma ev_False: "ev (\x. False) \ \ False"
proof
  assume "ev (\x. False) \" then show False
    by induct auto
qed auto

lemma alw_False: "alw (\x. False) \ \ False"
  by auto

lemma ev_iff_sdrop: "ev P \ \ (\m. P (sdrop m \))"
proof safe
  assume "ev P \" then show "\m. P (sdrop m \)"
    by (induct rule: ev_induct_strong) (auto intro: exI[of _ 0] exI[of _ "Suc n" for n])
next
  fix m assume "P (sdrop m \)" then show "ev P \"
    by (induct m arbitrary: ψ) auto
qed

lemma alw_iff_sdrop: "alw P \ \ (\m. P (sdrop m \))"
proof safe
  fix m assume "alw P \" then show "P (sdrop m \)"
    by (induct m arbitrary: ψ) auto
next
  assume "\m. P (sdrop m \)" then show "alw P \"
    by (coinduction arbitrary: ψ) (auto elim: allE[of _ 0] allE[of _ "Suc n" for n])
qed

lemma infinite_iff_alw_ev: "infinite {m. P (sdrop m \)} \ alw (ev P) \"
  unfolding infinite_nat_iff_unbounded_le alw_iff_sdrop ev_iff_sdrop
  by simp (metis le_Suc_ex le_add1)

lemma alw_inv:
  assumes stl: "\s. f (stl s) = stl (f s)"
  shows "alw P (f s) \ alw (\x. P (f x)) s"
proof
  assume "alw P (f s)" then show "alw (\x. P (f x)) s"
    by (coinduction arbitrary: s rule: alw_coinduct)
       (auto simp: stl)
next
  assume "alw (\x. P (f x)) s" then show "alw P (f s)"
    by (coinduction arbitrary: s rule: alw_coinduct) (auto simp flip: stl)
qed

lemma ev_inv:
  assumes stl: "\s. f (stl s) = stl (f s)"
  shows "ev P (f s) \ ev (\x. P (f x)) s"
proof
  assume "ev P (f s)" then show "ev (\x. P (f x)) s"
    by (induction "f s" arbitrary: s) (auto simp: stl)
next
  assume "ev (\x. P (f x)) s" then show "ev P (f s)"
    by induction (auto simp flip: stl)
qed

lemma alw_smap: "alw P (smap f s) \ alw (\x. P (smap f x)) s"
  by (rule alw_inv) simp

lemma ev_smap: "ev P (smap f s) \ ev (\x. P (smap f x)) s"
  by (rule ev_inv) simp

lemma alw_cong:
  assumes P: "alw P \" and eq: "\\. P \ \ Q1 \ \ Q2 \"
  shows "alw Q1 \ \ alw Q2 \"
proof -
  from eq have "(alw P aand Q1) = (alw P aand Q2)" by auto
  then have "alw (alw P aand Q1) \ = alw (alw P aand Q2) \" by auto
  with P show "alw Q1 \ \ alw Q2 \"
    by (simp add: alw_aand)
qed

lemma ev_cong:
  assumes P: "alw P \" and eq: "\\. P \ \ Q1 \ \ Q2 \"
  shows "ev Q1 \ \ ev Q2 \"
proof -
  from P have "alw (\xs. Q1 xs \ Q2 xs) \" by (rule alw_mono) (simp add: eq)
  moreover from P have "alw (\xs. Q2 xs \ Q1 xs) \" by (rule alw_mono) (simp add: eq)
  moreover note ev_alw_impl[of Q1 ψ Q2] ev_alw_impl[of Q2 ψ Q1]
  ultimately show "ev Q1 \ \ ev Q2 \"
    by auto
qed

lemma alwD: "alw P x \ P x"
  by auto

lemma alw_alwD: "alw P \ \ alw (alw P) \"
  by simp

lemma alw_ev_stl: "alw (ev P) (stl \) \ alw (ev P) \"
  by (auto intro: alw.intros)

lemma holds_Stream: "holds P (x ## s) \ P x"
  by simp

lemma holds_eq1[simp]: "holds ((=) x) = HLD {x}"
  by rule (auto simp: HLD_iff)

lemma holds_eq2[simp]: "holds (\y. y = x) = HLD {x}"
  by rule (auto simp: HLD_iff)

lemma not_holds_eq[simp]: "holds (- (=) x) = not (HLD {x})"
  by rule (auto simp: HLD_iff)

text ‹Strong until›

context
  notes [[inductive_internals]]
begin

inductive suntil (infix ‹suntil› 60) for φ ψ where
  base: "\ \ \ (\ suntil \) \"
| step: "\ \ \ (\ suntil \) (stl \) \ (\ suntil \) \"

inductive_simps suntil_Stream: "(\ suntil \) (x ## s)"

end

lemma suntil_induct_strong[consumes 1, case_names base step]:
  "(\ suntil \) x \
    (∧ψ. ψ ψ ==> P ψ) ==>
    (∧ψ. φ ψ ==> ¬ ψ ψ ==> (φ suntil ψ) (stl ψ) ==> P (stl ψ) ==> P ψ) ==> P x"
  using suntil.induct[of φ ψ x P] by blast

lemma ev_suntil: "(\ suntil \) \ \ ev \ \"
  by (induct rule: suntil.induct) auto

lemma suntil_inv:
  assumes stl: "\s. f (stl s) = stl (f s)"
  shows "(P suntil Q) (f s) \ ((\x. P (f x)) suntil (\x. Q (f x))) s"
proof
  assume "(P suntil Q) (f s)" then show "((\x. P (f x)) suntil (\x. Q (f x))) s"
    by (induction "f s" arbitrary: s) (auto simp: stl intro: suntil.intros)
next
  assume "((\x. P (f x)) suntil (\x. Q (f x))) s" then show "(P suntil Q) (f s)"
    by induction (auto simp flip: stl intro: suntil.intros)
qed

lemma suntil_smap: "(P suntil Q) (smap f s) \ ((\x. P (smap f x)) suntil (\x. Q (smap f x))) s"
  by (rule suntil_inv) simp

lemma hld_smap: "HLD x (smap f s) = holds (\y. f y \ x) s"
  by (simp add: HLD_def)

lemma suntil_mono:
  assumes eq: "\\. P \ \ Q1 \ \ Q2 \" "\\. P \ \ R1 \ \ R2 \"
  assumes *: "(Q1 suntil R1) \" "alw P \" shows "(Q2 suntil R2) \"
  using * by induct (auto intro: eq suntil.intros)

lemma suntil_cong:
  "alw P \ \ (\\. P \ \ Q1 \ \ Q2 \) \ (\\. P \ \ R1 \ \ R2 \) \
    (Q1 suntil R1) ψ ⟷ (Q2 suntil R2) ψ"
  using suntil_mono[of P Q1 Q2 R1 R2 ψ] suntil_mono[of P Q2 Q1 R2 R1 ψ] by auto

lemma ev_suntil_iff: "ev (P suntil Q) \ \ ev Q \"
proof
  assume "ev (P suntil Q) \" then show "ev Q \"
   by induct (auto dest: ev_suntil)
next
  assume "ev Q \" then show "ev (P suntil Q) \"
    by induct (auto intro: suntil.intros)
qed

lemma true_suntil: "((\_. True) suntil P) = ev P"
  by (simp add: suntil_def ev_def)

lemma suntil_lfp: "(\ suntil \) = lfp (\P s. \ s \ (\ s \ P (stl s)))"
  by (simp add: suntil_def)

lemma sfilter_P[simp]: "P (shd s) \ sfilter P s = shd s ## sfilter P (stl s)"
  using sfilter_Stream[of P "shd s" "stl s"] by simp

lemma sfilter_not_P[simp]: "\ P (shd s) \ sfilter P s = sfilter P (stl s)"
  using sfilter_Stream[of P "shd s" "stl s"] by simp

lemma sfilter_eq:
  assumes "ev (holds P) s"
  shows "sfilter P s = x ## s' \
    P x ∧ (not (holds P) suntil (HLD {x} aand nxt (λs. sfilter P s = s'))) s"
  using assms
  by (induct rule: ev_induct_strong)
     (auto simp add: HLD_iff intro: suntil.intros elim: suntil.cases)

lemma sfilter_streams:
  "alw (ev (holds P)) \ \ \ \ streams A \ sfilter P \ \ streams {x\A. P x}"
proof (coinduction arbitrary: ψ)
  case (streams ψ)
  then have "ev (holds P) \" by blast
  from this streams show ?case
    by (induct rule: ev_induct_strong) (auto elim: streamsE)
qed

lemma alw_sfilter:
  assumes *: "alw (ev (holds P)) s"
  shows "alw Q (sfilter P s) \ alw (\x. Q (sfilter P x)) s"
proof
  assume "alw Q (sfilter P s)" with * show "alw (\x. Q (sfilter P x)) s"
  proof (coinduction arbitrary: s rule: alw_coinduct)
    case (stl s)
    then have "ev (holds P) s"
      by blast
    from this stl show ?case
      by (induct rule: ev_induct_strong) auto
  qed auto
next
  assume "alw (\x. Q (sfilter P x)) s" with * show "alw Q (sfilter P s)"
  proof (coinduction arbitrary: s rule: alw_coinduct)
    case (stl s)
    then have "ev (holds P) s"
      by blast
    from this stl show ?case
      by (induct rule: ev_induct_strong) auto
  qed auto
qed

lemma ev_sfilter:
  assumes *: "alw (ev (holds P)) s"
  shows "ev Q (sfilter P s) \ ev (\x. Q (sfilter P x)) s"
proof
  assume "ev Q (sfilter P s)" from this * show "ev (\x. Q (sfilter P x)) s"
  proof (induction "sfilter P s" arbitrary: s rule: ev_induct_strong)
    case (step s)
    then have "ev (holds P) s"
      by blast
    from this step show ?case
      by (induct rule: ev_induct_strong) auto
  qed auto
next
  assume "ev (\x. Q (sfilter P x)) s" then show "ev Q (sfilter P s)"
  proof (induction rule: ev_induct_strong)
    case (step s) then show ?case
      by (cases "P (shd s)") auto
  qed auto
qed

lemma holds_sfilter:
  assumes "ev (holds Q) s" shows "holds P (sfilter Q s) \ (not (holds Q) suntil (holds (Q aand P))) s"
proof
  assume "holds P (sfilter Q s)" with assms show "(not (holds Q) suntil (holds (Q aand P))) s"
    by (induct rule: ev_induct_strong) (auto intro: suntil.intros)
next
  assume "(not (holds Q) suntil (holds (Q aand P))) s" then show "holds P (sfilter Q s)"
    by induct auto
qed

lemma suntil_aand_nxt:
  "(\ suntil (\ aand nxt \)) \ \ (\ aand nxt (\ suntil \)) \"
proof
  assume "(\ suntil (\ aand nxt \)) \" then show "(\ aand nxt (\ suntil \)) \"
    by induction (auto intro: suntil.intros)
next
  assume "(\ aand nxt (\ suntil \)) \"
  then have "(\ suntil \) (stl \)" "\ \"
    by auto
  then show "(\ suntil (\ aand nxt \)) \"
    by (induction "stl \" arbitrary: ψ)
       (auto elim: suntil.cases intro: suntil.intros)
qed

lemma alw_sconst: "alw P (sconst x) \ P (sconst x)"
proof
  assume "P (sconst x)" then show "alw P (sconst x)"
    by coinduction auto
qed auto

lemma ev_sconst: "ev P (sconst x) \ P (sconst x)"
proof
  assume "ev P (sconst x)" then show "P (sconst x)"
    by (induction "sconst x") auto
qed auto

lemma suntil_sconst: "(\ suntil \) (sconst x) \ \ (sconst x)"
proof
  assume "(\ suntil \) (sconst x)" then show "\ (sconst x)"
    by (induction "sconst x") auto
qed (auto intro: suntil.intros)

lemma hld_smap': "HLD x (smap f s) = HLD (f -` x) s"
  by (simp add: HLD_def)

lemma pigeonhole_stream:
  assumes "alw (HLD s) \"
  assumes "finite s"
  shows "\x\s. alw (ev (HLD {x})) \"
proof -
  have "\i\UNIV. \x\s. \ !! i = x"
    using ‹alw (HLD s) ψ› by (simp add: alw_iff_sdrop HLD_iff)
  from pigeonhole_infinite_rel[OF infinite_UNIV_nat ‹finite s› this]
  show ?thesis
    by (simp add: HLD_iff flip: infinite_iff_alw_ev)
qed

lemma ev_eq_suntil: "ev P \ \ (not P suntil P) \"
proof
  assume "ev P \" then show "((\xs. \ P xs) suntil P) \"
    by (induction rule: ev_induct_strong) (auto intro: suntil.intros)
qed (auto simp: ev_suntil)

section ‹Weak vs. strong until (contributed by Michael Foster, University of Sheffield)›

lemma suntil_implies_until: "(\ suntil \) \ \ (\ until \) \"
  by (induct rule: suntil_induct_strong) (auto intro: UNTIL.intros)

lemma alw_implies_until: "alw \ \ \ (\ until \) \"
  unfolding until_false[symmetric] by (auto elim: until_mono)

lemma until_ev_suntil: "(\ until \) \ \ ev \ \ \ (\ suntil \) \"
proof (rotate_tac, induction rule: ev.induct)
  case (base xs)
  then show ?case
    by (simp add: suntil.base)
next
  case (step xs)
  then show ?case
    by (metis UNTIL.cases suntil.base suntil.step)
qed

lemma suntil_as_until: "(\ suntil \) \ = ((\ until \) \ \ ev \ \)"
  using ev_suntil suntil_implies_until until_ev_suntil by blast

lemma until_not_relesased_now: "(\ until \) \ \ \ \ \ \ \ \"
  using UNTIL.cases by auto

lemma until_must_release_ev: "(\ until \) \ \ ev (not \) \ \ ev \ \"
proof (rotate_tac, induction rule: ev.induct)
  case (base xs)
  then show ?case
    using until_not_relesased_now by blast
next
  case (step xs)
  then show ?case
    using UNTIL.cases by blast
qed

lemma until_as_suntil: "(\ until \) \ = ((\ suntil \) or (alw \)) \"
  using alw_implies_until not_alw_iff suntil_implies_until until_ev_suntil until_must_release_ev
  by blast

lemma alw_holds: "alw (holds P) (h##t) = (P h \ alw (holds P) t)"
  by (metis alw.simps holds_Stream stream.sel(2))

lemma alw_holds2: "alw (holds P) ss = (P (shd ss) \ alw (holds P) (stl ss))"
  by (meson alw.simps holds.elims(2) holds.elims(3))

lemma alw_eq_sconst: "(alw (HLD {h}) t) = (t = sconst h)"
  unfolding sconst_alt alw_HLD_iff_streams streams_iff_sset
  using stream.set_sel(1) by force

lemma sdrop_if_suntil: "(p suntil q) \ \ \j. q (sdrop j \) \ (\k < j. p (sdrop k \))"
proof(induction rule: suntil.induct)
  case (base ψ)
  then show ?case
    by force
next
  case (step ψ)
  then obtain j where "q (sdrop j (stl \))" "\k))" by blast
  with step(1,2) show ?case
    using ev_at_imp_snth less_Suc_eq_0_disj by (auto intro!: exI[where x="j+1"])
qed

lemma not_suntil: "(\ (p suntil q) \) = (\ (p until q) \ \ alw (not q) \)"
  by (simp add: suntil_as_until alw_iff_sdrop ev_iff_sdrop)

lemma sdrop_until: "q (sdrop j \) \ \k) \ (p until q) \"
proof(induct j arbitrary: ψ)
  case 0
  then show ?case
    by (simp add: UNTIL.base)
next
  case (Suc j)
  then show ?case
    by (metis Suc_mono UNTIL.simps sdrop.simps(1) sdrop.simps(2) zero_less_Suc)
qed

lemma sdrop_suntil: "q (sdrop j \) \ (\k < j. p (sdrop k \)) \ (p suntil q) \"
  by (metis ev_iff_sdrop sdrop_until suntil_as_until)

lemma suntil_iff_sdrop: "(p suntil q) \ = (\j. q (sdrop j \) \ (\k < j. p (sdrop k \)))"
  using sdrop_if_suntil sdrop_suntil by blast

end