(*<*)
theory Extended_Typed_Lambda_Calculus
imports
  Main
  "List-Index.List_Index"
  "HOL-Eisbach.Eisbach"
  "HOL-Eisbach.Eisbach_Tools"
  "HOL-IMP.Star"
begin
(*>*)

section {* Derived form*}

text{*
    This part will cover the classical lambda calculus extended with booleans , unit type,
    type variables and sequence in two different ways. The goal is to show that
    both implementations are  equivalent up to some isomorphism (e)
    with respect to evaluation and typing.
*}

subsection {* Definitions *}

(* Redefinition of the typed lambda calculus
   and properties with extended types

   We add base types T(1) T(2) .... and Unit
 *)

datatype ltype =
  Bool |
  T (num:nat) |
  Unit |
  Fun (domain: ltype) (codomain: ltype) (infixr "\<rightarrow>" 225)

(* internal language definition with Unit only*)
datatype ltermI =
  LTrue |
  LFalse |
  LIf (bool_expr: ltermI) (then_expr: ltermI) (else_expr: ltermI) |
  LVar nat |
  LAbs (arg_type: ltype) (body: ltermI) |
  LApp ltermI ltermI |
  unit

primrec shift_L :: "int \<Rightarrow> nat \<Rightarrow> ltermI \<Rightarrow> ltermI" where
  "shift_L d c LTrue = LTrue" |
  "shift_L d c LFalse = LFalse" |
  "shift_L d c (LIf t1 t2 t3) = LIf (shift_L d c t1) (shift_L d c t2) (shift_L d c t3)" |
  "shift_L d c (LVar k) = LVar (if k < c then k else nat (int k + d))" |
  "shift_L d c (LAbs A t) = LAbs A (shift_L d (Suc c) t)" |
  "shift_L d c (LApp t1 t2) = LApp (shift_L d c t1) (shift_L d c t2)" |
  "shift_L d c unit = unit"

primrec subst_L :: "nat \<Rightarrow> ltermI \<Rightarrow> ltermI \<Rightarrow> ltermI" where
  "subst_L j s LTrue = LTrue" |
  "subst_L j s LFalse = LFalse" |
  "subst_L j s (LIf t1 t2 t3) = LIf (subst_L j s t1) (subst_L j s t2) (subst_L j s t3)" |
  "subst_L j s (LVar k) = (if k = j then s else LVar k)" |
  "subst_L j s (LAbs T' t) = LAbs T' (subst_L (Suc j) (shift_L 1 0 s) t)" |
  "subst_L j s (LApp t1 t2) = LApp (subst_L j s t1) (subst_L j s t2)" |
  "subst_L j s unit = unit"

(* unit is a value*)
inductive is_value_L :: "ltermI \<Rightarrow> bool" where
  "is_value_L LTrue" |
  "is_value_L LFalse" |
  "is_value_L (LAbs T' t)" |
  "is_value_L unit"

(*
  a sequence is only valid if FV t2 doesn't contain 0
  so we will only consider shifted term t2 (always a valid term)
*)

abbreviation sequence :: "ltermI\<Rightarrow>ltermI\<Rightarrow>ltermI" (infix ";;" 200) where
 "sequence t1 t2 \<equiv> (LApp (LAbs Unit  (shift_L 1 0 t2)) t1)"

primrec FV :: "ltermI \<Rightarrow> nat set" where
  "FV LTrue = {}" |
  "FV LFalse = {}" |
  "FV (LIf t1 t2 t3) = FV t1 \<union> FV t2 \<union> FV t3" |
  "FV (LVar x) = {x}" |
  "FV (LAbs T1 t) = image (\<lambda>x. x - 1) (FV t - {0})" |
  "FV (LApp t1 t2) = FV t1 \<union> FV t2" |
  "FV unit = {}"

inductive eval1_L :: "ltermI \<Rightarrow> ltermI \<Rightarrow> bool" where
  \<comment> \<open>Rules relating to the evaluation of Booleans\<close>
  eval1_LIf_LTrue:
    "eval1_L (LIf LTrue t2 t3) t2" |
  eval1_LIf_LFalse:
    "eval1_L (LIf LFalse t2 t3) t3" |
  eval1_LIf:
    "eval1_L t1 t1' \<Longrightarrow> eval1_L (LIf t1 t2 t3) (LIf t1' t2 t3)" |

  \<comment> \<open>Rules relating to the evaluation of function application\<close>
  eval1_LApp1:
    "eval1_L t1 t1' \<Longrightarrow> eval1_L (LApp t1 t2) (LApp t1' t2)" |
  eval1_LApp2:
    "is_value_L v1 \<Longrightarrow> eval1_L t2 t2' \<Longrightarrow> eval1_L (LApp v1 t2) (LApp v1 t2')" |
  eval1_LApp_LAbs:
    "is_value_L v2 \<Longrightarrow> eval1_L (LApp (LAbs T' t12) v2)
      (shift_L (-1) 0 (subst_L 0 (shift_L 1 0 v2) t12))"

inductive_cases eval1_LIf_E: "eval1_L (LIf t t1 t2) t'"
inductive_cases eval1_LApp_E: "eval1_L (LApp t1 t2) t'"

type_synonym lcontext = "ltype list"

notation Nil ("\<emptyset>")
abbreviation cons :: "lcontext \<Rightarrow> ltype \<Rightarrow> lcontext" (infixl "|,|" 200) where
  "cons \<Gamma> T' \<equiv> T' # \<Gamma>"
abbreviation elem' :: "(nat \<times> ltype) \<Rightarrow> lcontext \<Rightarrow> bool" (infix "|\<in>|" 200) where
  "elem' p \<Gamma> \<equiv> fst p < length \<Gamma> \<and> snd p = nth \<Gamma> (fst p)"

(* had new typing rule for unit and sequence*)
inductive has_type_L :: "lcontext \<Rightarrow> ltermI \<Rightarrow> ltype \<Rightarrow> bool" ("((_)/ \<turnstile> (_)/ |:| (_))" [150, 150, 150] 150) where
  \<comment> \<open>Rules relating to the type of Booleans\<close>
  has_type_LTrue:
    "\<Gamma> \<turnstile> LTrue |:| Bool" |
  has_type_LFalse:
    "\<Gamma> \<turnstile> LFalse |:| Bool" |
  has_type_LIf:
    "\<Gamma> \<turnstile> t1 |:| Bool \<Longrightarrow> \<Gamma> \<turnstile> t2 |:| T' \<Longrightarrow> \<Gamma> \<turnstile> t3 |:| T' \<Longrightarrow> \<Gamma> \<turnstile> (LIf t1 t2 t3) |:| T'" |

  \<comment> \<open>Rules relating to the type of the constructs of the $\lambda$-calculus\<close>
  has_type_LVar:
    "(x, T') |\<in>| \<Gamma> \<Longrightarrow> \<Gamma> \<turnstile> (LVar x) |:| (T')" |
  has_type_LAbs:
    "(\<Gamma> |,| T1) \<turnstile> t2 |:| T2 \<Longrightarrow> \<Gamma> \<turnstile> (LAbs T1 t2) |:| (T1 \<rightarrow> T2)" |
  has_type_LApp:
    "\<Gamma> \<turnstile> t1 |:| (T11 \<rightarrow> T12) \<Longrightarrow> \<Gamma> \<turnstile> t2 |:| T11 \<Longrightarrow> \<Gamma> \<turnstile> (LApp t1 t2) |:| T12" |
  has_type_LUnit:
    "\<Gamma> \<turnstile> unit |:| Unit"

lemma gr_Suc_conv: "Suc x \<le> n \<longleftrightarrow> (\<exists>m. n = Suc m \<and> x \<le> m)"
  by (cases n) auto

lemma FV_shift:
  "FV (shift_L (int d) c t) = image (\<lambda>x. if x \<ge> c then x + d else x) (FV t)"
proof (induction t arbitrary: c rule: ltermI.induct)
  case (LAbs A t)
    thus ?case by (auto simp: gr_Suc_conv image_iff) force+
qed auto

lemmas int_1 = of_nat_1[where 'a=int]

lemma FV_subst:
  "FV (subst_L n t u) = (if n \<in> FV u then (FV u - {n}) \<union> FV t else FV u)"
proof (induction u arbitrary: n t rule: ltermI.induct)
  case (LAbs T u)
  thus ?case
    by (auto simp: gr0_conv_Suc image_iff FV_shift[of 1, unfolded int_1],
        (metis DiffI One_nat_def UnCI diff_Suc_1 empty_iff imageI insert_iff nat.distinct(1))+)
qed (auto simp: gr0_conv_Suc image_iff FV_shift[of 1, unfolded int_1])

(* inversion, uniqueness and canonical form updated with unit*)
lemma inversion:
  "\<Gamma> \<turnstile> LTrue |:| R \<Longrightarrow> R = Bool"
  "\<Gamma> \<turnstile> LFalse |:| R \<Longrightarrow> R = Bool"
  "\<Gamma> \<turnstile> LIf t1 t2 t3 |:| R \<Longrightarrow> \<Gamma> \<turnstile> t1 |:| Bool \<and> \<Gamma> \<turnstile> t2 |:| R \<and> \<Gamma> \<turnstile> t3 |:| R"
  "\<Gamma> \<turnstile> LVar x |:| R \<Longrightarrow> (x, R) |\<in>| \<Gamma>"
  "\<Gamma> \<turnstile> LAbs T1 t2 |:| R \<Longrightarrow> \<exists>R2. R = T1 \<rightarrow> R2 \<and> \<Gamma> |,| T1 \<turnstile> t2 |:| R2"
  "\<Gamma> \<turnstile> LApp t1 t2 |:| R \<Longrightarrow> \<exists>T11. \<Gamma> \<turnstile> t1 |:| T11 \<rightarrow> R \<and> \<Gamma> \<turnstile> t2 |:| T11"
  "\<Gamma> \<turnstile>  unit |:| R \<Longrightarrow> R = Unit"
  by (auto elim: has_type_L.cases)

theorem uniqueness_of_types:
  "\<Gamma> \<turnstile> t |:| T1 \<Longrightarrow> \<Gamma> \<turnstile> t |:| T2 \<Longrightarrow> T1 = T2"
by (induction \<Gamma> t T1 arbitrary: T2 rule: has_type_L.induct)
  (metis prod.sel ltype.sel inversion)+

lemma canonical_forms:
  "is_value_L v \<Longrightarrow> \<Gamma> \<turnstile> v |:| Bool \<Longrightarrow> v = LTrue \<or> v = LFalse"
  "is_value_L v \<Longrightarrow> \<Gamma> \<turnstile> v |:| T1 \<rightarrow> T2 \<Longrightarrow> \<exists>t. v = LAbs T1 t"
  "is_value_L v \<Longrightarrow> \<Gamma> \<turnstile> v |:| Unit \<Longrightarrow> v = unit"
by (auto elim: has_type_L.cases is_value_L.cases)

lemma shift_down:
  "insert_nth n U \<Gamma> \<turnstile> t |:| A \<Longrightarrow> n \<le> length \<Gamma> \<Longrightarrow>
   (\<And>x. x \<in> FV t \<Longrightarrow> x \<noteq> n) \<Longrightarrow> \<Gamma> \<turnstile> shift_L (-1) n t |:| A"
proof (induction "insert_nth n U \<Gamma>" t A arbitrary: \<Gamma> n rule: has_type_L.induct)
  case (has_type_LAbs V t A)
  from this(1,3,4) show ?case
    by (fastforce intro: has_type_L.intros has_type_LAbs.hyps(2)[where n="Suc n"])+
qed (fastforce intro: has_type_L.intros simp: nth_append min_def)+

lemma weakening:
  "\<Gamma> \<turnstile> t |:| A \<Longrightarrow> n \<le> length \<Gamma> \<Longrightarrow> insert_nth n S \<Gamma> \<turnstile> shift_L 1 n t |:| A"
proof (induction \<Gamma> t A arbitrary: n rule: has_type_L.induct)
  case (has_type_LAbs \<Gamma> T1 t2 T2)
    show ?case
      using has_type_LAbs(1,3) has_type_LAbs.IH[where n="Suc n"]
      by (auto intro: has_type_L.intros)
qed (auto simp: nth_append min_def intro: has_type_L.intros)

(* sequence specific lemmas
    evaluation
    typing
*)

theorem eval1_Lseq:
  "eval1_L t1 t1' \<Longrightarrow> eval1_L (t1;;t2) (t1';;t2)"
  by (auto intro: eval1_L.intros is_value_L.intros)

lemma subst_free_var_only: "x\<notin>FV t \<Longrightarrow> subst_L x t1 t = t"
by (induction t arbitrary:t1 x, force+)

lemma shift_shift_invert: "a>0 \<Longrightarrow> shift_L (-a) b (shift_L a b t) = t"
by (induction t arbitrary: a b, auto)

lemma shift_upper_vars: "c\<notin>FV t \<Longrightarrow> shift_L d c t = shift_L d (Suc c) t"
proof (induction t arbitrary: d c)
  case (LAbs A t)
    show ?case
      using LAbs(2)[unfolded "FV.simps" image_iff]
            LAbs(1)[of "Suc c"]
      by force
qed auto

theorem eval1_Lseq_next:
  " eval1_L (unit ;; t2) t2"
proof -
  have A:"eval1_L (unit ;; t2) (shift_L (-1) 0 (subst_L 0 (shift_L 1 0 unit) (shift_L 1 0 t2)))"
    using eval1_LApp_LAbs
          "is_value_L.simps"
     by presburger

  have B:" subst_L 0 (shift_L 1 0 unit) (shift_L 1 0 t2) = (shift_L 1 0 t2)"
    using subst_free_var_only[of 0 "shift_L 1 0 t2" unit]
          FV_shift[of 1 0 t2]
          image_iff
    by auto
  show ?thesis
    using A[unfolded B] shift_shift_invert
    by force
qed

lemma eval1_LSeq_E:
  fixes t1 t2 t':: ltermI
  assumes H:"eval1_L (t1;;t2) t'" and
          step1: "\<And>t1'. eval1_L t1 t1' \<Longrightarrow> t' = (t1';;t2) \<Longrightarrow> P" and
          step2: "t1 = unit \<Longrightarrow> t' = t2 \<Longrightarrow> P" and
          step3: "is_value_L t1 \<Longrightarrow> t' = t2 \<Longrightarrow> P"
  shows "P"
using assms
proof (induction "(t1;;t2)" t' rule:eval1_L.induct)
  case (eval1_LApp_LAbs)
    have "shift_L (-1) 0 (subst_L 0 (shift_L 1 0 t1) (shift_L 1 0 t2)) = t2"
      using subst_free_var_only[of 0 "shift_L 1 0 t2"  "shift_L 1 0 t1" ]  eval1_LApp_LAbs(2)
            shift_shift_invert FV_shift[of 1 0 t2]
      by force
    with "eval1_LApp_LAbs.hyps" "eval1_LApp_LAbs.prems"(3)
      show ?case
        by auto
qed (auto elim: eval1_L.cases)

theorem has_type_LSeq:
  "\<Gamma> \<turnstile> t1 |:| Unit \<Longrightarrow> \<Gamma> \<turnstile> t2 |:| A \<Longrightarrow> \<Gamma> \<turnstile> (t1 ;; t2) |:| A"
using has_type_LAbs has_type_LApp
      weakening[of _ t2 A 0 Unit]
by fastforce

(* external language definition with sequence as a term*)
datatype ltermE =
  LETrue |
  LEFalse |
  LEIf (bool_expr: ltermE) (then_expr: ltermE) (else_expr: ltermE) |
  LEVar nat |
  LEAbs (arg_type: ltype) (body: ltermE) |
  LEApp ltermE ltermE |
  unitE |
  SeqE (fp: ltermE) (sp: ltermE)

primrec shift_LE :: "int \<Rightarrow> nat \<Rightarrow> ltermE \<Rightarrow> ltermE" where
  "shift_LE d c LETrue = LETrue" |
  "shift_LE d c LEFalse = LEFalse" |
  "shift_LE d c (LEIf t1 t2 t3) = LEIf (shift_LE d c t1) (shift_LE d c t2) (shift_LE d c t3)" |
  "shift_LE d c (LEVar k) = LEVar (if k < c then k else nat (int k + d))" |
  "shift_LE d c (LEAbs A t) = LEAbs A (shift_LE d (Suc c) t)" |
  "shift_LE d c (LEApp t1 t2) = LEApp (shift_LE d c t1) (shift_LE d c t2)" |
  "shift_LE d c unitE = unitE"|
"shift_LE d c (SeqE t1 t2) =
SeqE (shift_LE d c t1) (shift_LE d c t2)"

primrec subst_LE :: "nat \<Rightarrow> ltermE \<Rightarrow> ltermE \<Rightarrow> ltermE" where
  "subst_LE j s LETrue = LETrue" |
  "subst_LE j s LEFalse = LEFalse" |
  "subst_LE j s (LEIf t1 t2 t3) = LEIf (subst_LE j s t1) (subst_LE j s t2) (subst_LE j s t3)" |
  "subst_LE j s (LEVar k) = (if k = j then s else LEVar k)" |
  "subst_LE j s (LEAbs T' t) = LEAbs T' (subst_LE (Suc j) (shift_LE 1 0 s) t)" |
  "subst_LE j s (LEApp t1 t2) = LEApp (subst_LE j s t1) (subst_LE j s t2)" |
  "subst_LE j s unitE = unitE" |
  "subst_LE j s (SeqE t1 t2) = SeqE (subst_LE j s t1) (subst_LE j s t2)"

(* unit is a value*)
inductive is_value_LE :: "ltermE \<Rightarrow> bool" where
  "is_value_LE LETrue" |
  "is_value_LE LEFalse" |
  "is_value_LE (LEAbs T' t)" |
  "is_value_LE unitE"

primrec FVE :: "ltermE \<Rightarrow> nat set" where
  "FVE LETrue = {}" |
  "FVE LEFalse = {}" |
  "FVE (LEIf t1 t2 t3) = FVE t1 \<union> FVE t2 \<union> FVE t3" |
  "FVE (LEVar x) = {x}" |
  "FVE (LEAbs T1 t) = image (\<lambda>x. x - 1) (FVE t - {0})" |
  "FVE (LEApp t1 t2) = FVE t1 \<union> FVE t2" |
  "FVE unitE = {}" |
  "FVE (SeqE t1 t2) = FVE t1 \<union> (FVE t2)"

inductive eval1_LE :: "ltermE \<Rightarrow> ltermE \<Rightarrow> bool" where
  \<comment> \<open>Rules relating to the evaluation of Booleans\<close>
  eval1_LEIf_LTrue:
    "eval1_LE (LEIf LETrue t2 t3) t2" |
  eval1_LEIf_LFalse:
    "eval1_LE (LEIf LEFalse t2 t3) t3" |
  eval1_LEIf:
    "eval1_LE t1 t1' \<Longrightarrow> eval1_LE (LEIf t1 t2 t3) (LEIf t1' t2 t3)" |

  \<comment> \<open>Rules relating to the evaluation of function application\<close>
  eval1_LEApp1:
    "eval1_LE t1 t1' \<Longrightarrow> eval1_LE (LEApp t1 t2) (LEApp t1' t2)" |
  eval1_LEApp2:
    "is_value_LE v1 \<Longrightarrow> eval1_LE t2 t2' \<Longrightarrow> eval1_LE (LEApp v1 t2) (LEApp v1 t2')" |
  eval1_LEApp_LEAbs:
    "is_value_LE v2 \<Longrightarrow> eval1_LE (LEApp (LEAbs T' t12) v2)
      (shift_LE (-1) 0 (subst_LE 0 (shift_LE 1 0 v2) t12))" |

  \<comment> \<open>Rules relating to evaluation of sequence\<close>
  eval1_LE_E_Seq:
    "eval1_LE t1 t1' \<Longrightarrow> eval1_LE (SeqE t1 t2) (SeqE t1' t2)" |
  eval1_LE_E_Seq_Next:
    "eval1_LE (SeqE unitE t2) t2"

inductive_cases eval1_LEIf_E: "eval1_LE (LEIf t t1 t2) t'"
inductive_cases eval1_LEApp_E: "eval1_LE (LEApp t1 t2) t'"
inductive_cases eval1_LESeq_E: "eval1_LE (SeqE t1 t2) t'"

(* had new typing rule for unit and sequence*)
inductive has_type_LE :: "lcontext \<Rightarrow> ltermE \<Rightarrow> ltype \<Rightarrow> bool" ("((_)/ \<turnstile>\<^sup>E (_)/ |:| (_))" [150, 150, 150] 150) where
  \<comment> \<open>Rules relating to the type of Booleans\<close>
  has_type_LETrue:
    "\<Gamma> \<turnstile>\<^sup>E LETrue |:| Bool" |
  has_type_LEFalse:
    "\<Gamma> \<turnstile>\<^sup>E LEFalse |:| Bool" |
  has_type_LEIf:
    "\<Gamma> \<turnstile>\<^sup>E t1 |:| Bool \<Longrightarrow> \<Gamma> \<turnstile>\<^sup>E t2 |:| T' \<Longrightarrow> \<Gamma> \<turnstile>\<^sup>E t3 |:| T' \<Longrightarrow> \<Gamma> \<turnstile>\<^sup>E (LEIf t1 t2 t3) |:| T'" |

  \<comment> \<open>Rules relating to the type of the constructs of the $\lambda$-calculus\<close>
  has_type_LEVar:
    "(x, T') |\<in>| \<Gamma> \<Longrightarrow> \<Gamma> \<turnstile>\<^sup>E (LEVar x) |:| (T')" |
  has_type_LEAbs:
    "(\<Gamma> |,| T1) \<turnstile>\<^sup>E t2 |:| T2 \<Longrightarrow> \<Gamma> \<turnstile>\<^sup>E (LEAbs T1 t2) |:| (T1 \<rightarrow> T2)" |
  has_type_LEApp:
    "\<Gamma> \<turnstile>\<^sup>E t1 |:| (T11 \<rightarrow> T12) \<Longrightarrow> \<Gamma> \<turnstile>\<^sup>E t2 |:| T11 \<Longrightarrow> \<Gamma> \<turnstile>\<^sup>E (LEApp t1 t2) |:| T12" |

  has_type_LEUnit:
    "\<Gamma> \<turnstile>\<^sup>E unitE |:| Unit " |

  \<comment> \<open>Rule relating to sequence\<close>
  has_type_LESeqE:
    "\<Gamma> \<turnstile>\<^sup>E t1 |:| Unit \<Longrightarrow> \<Gamma> \<turnstile>\<^sup>E t2 |:| A \<Longrightarrow> \<Gamma> \<turnstile>\<^sup>E (SeqE t1 t2) |:| A"

lemma inversionE:
  "\<Gamma> \<turnstile>\<^sup>E LETrue |:| R \<Longrightarrow> R = Bool"
  "\<Gamma> \<turnstile>\<^sup>E LEFalse |:| R \<Longrightarrow> R = Bool"
  "\<Gamma> \<turnstile>\<^sup>E LEIf t1 t2 t3 |:| R \<Longrightarrow> \<Gamma> \<turnstile>\<^sup>E t1 |:| Bool \<and> \<Gamma> \<turnstile>\<^sup>E t2 |:| R \<and> \<Gamma> \<turnstile>\<^sup>E t3 |:| R"
  "\<Gamma> \<turnstile>\<^sup>E LEVar x |:| R \<Longrightarrow> (x, R) |\<in>| \<Gamma>"
  "\<Gamma> \<turnstile>\<^sup>E LEAbs T1 t2 |:| R \<Longrightarrow> \<exists>R2. R = T1 \<rightarrow> R2 \<and> \<Gamma> |,| T1 \<turnstile>\<^sup>E t2 |:| R2"
  "\<Gamma> \<turnstile>\<^sup>E LEApp t1 t2 |:| R \<Longrightarrow> \<exists>T11. \<Gamma> \<turnstile>\<^sup>E t1 |:| T11 \<rightarrow> R \<and> \<Gamma> \<turnstile>\<^sup>E t2 |:| T11"
  "\<Gamma> \<turnstile>\<^sup>E unitE |:| R \<Longrightarrow> R = Unit"
  "\<Gamma> \<turnstile>\<^sup>E SeqE t1 t2 |:| R \<Longrightarrow> \<exists>A. R = A \<and> \<Gamma> \<turnstile>\<^sup>E t2 |:| A \<and> \<Gamma> \<turnstile>\<^sup>E t1 |:| Unit"
  by (auto elim: has_type_LE.cases)

lemma canonical_formsE:
  "is_value_LE v \<Longrightarrow> \<Gamma> \<turnstile>\<^sup>E v |:| Bool \<Longrightarrow> v = LETrue \<or> v = LEFalse"
  "is_value_LE v \<Longrightarrow> \<Gamma> \<turnstile>\<^sup>E v |:| T1 \<rightarrow> T2 \<Longrightarrow> \<exists>t. v = LEAbs T1 t"
  "is_value_LE v \<Longrightarrow> \<Gamma> \<turnstile>\<^sup>E v |:| Unit \<Longrightarrow> v = unitE"
by (auto elim: has_type_LE.cases is_value_LE.cases)

lemma FVE_shift:
  "FVE (shift_LE (int d) c t) = image (\<lambda>x. if x \<ge> c then x + d else x) (FVE t)"
proof (induction t arbitrary: c rule: ltermE.induct)
  case (LEAbs T t)
    thus ?case
      by (auto simp: gr_Suc_conv image_iff) force+
qed auto

lemma weakeningE:
  "\<Gamma> \<turnstile>\<^sup>E t |:| A \<Longrightarrow> n \<le> length \<Gamma> \<Longrightarrow> insert_nth n S \<Gamma> \<turnstile>\<^sup>E shift_LE 1 n t |:| A"
proof (induction \<Gamma> t A arbitrary: n rule: has_type_LE.induct)
  case (has_type_LEAbs \<Gamma> T1 t2 T2)
    show ?case
      using has_type_LEAbs(1,3) has_type_LEAbs.IH[where n="Suc n"]
      by (auto intro: has_type_LE.intros)
next
  case (has_type_LESeqE \<Gamma> t1 t2 A)
    show ?case
      using FVE_shift[of 1 n] has_type_LESeqE(3,4,5)
      by (auto intro: has_type_LE.intros)
qed (auto simp: nth_append min_def intro: has_type_LE.intros)

(* Theorem 11.3.1 Sequence is a derived form*)

(*e is a translation function from external to internal language*)

fun e::"ltermE \<Rightarrow>  ltermI" where
  "e LETrue           =  LTrue" |
  "e LEFalse          =  LFalse" |
  "e (LEIf t1 t2 t3)  =  LIf (e t1) (e t2) (e t3)" |
  "e (LEVar x)        = LVar x" |
  "e (LEAbs A t1)     = LAbs A (e t1)" |
  "e (LEApp t1 t2) = LApp (e t1) (e t2)" |
  "e unitE = unit" |
  "e (SeqE t1 t2) = (e t1 ;; e t2)"

(*   This theorem shows that both implementation of sequence are
   equivalent in term of typing and evaluation
*)

lemma value_equiv: "is_value_LE v1 \<longleftrightarrow> is_value_L (e v1)" (is "?P \<longleftrightarrow> ?Q")
proof
  show "?P \<Longrightarrow> ?Q"
    by (induction rule: is_value_LE.induct, auto intro: is_value_L.intros)
next
  show "?Q \<Longrightarrow> ?P"
    by (induction rule: e.induct) (auto intro: is_value_LE.intros simp: "is_value_L.simps")
qed

lemma FV_equiv:
  "FV (e t) = FVE t"
proof (induction t)
  case (SeqE t1 t2)
    have "(\<lambda>x. x - Suc 0) ` (Suc ` FVE t2 - {0}) = FVE t2"
      by force
    thus ?case
      using FV_shift[of 1 0 "e t2"] SeqE
      by auto
qed auto

lemma shift_suc:
  "(\<And>x. x\<in>FV t \<Longrightarrow> x\<ge> c \<Longrightarrow> int x \<ge> -d \<and> int x + d \<ge> int c1) \<Longrightarrow> c\<ge>c1 \<Longrightarrow>  shift_L d (Suc c) (shift_L 1 c1 t) = shift_L 1 c1 (shift_L d c t)"
proof (induction t arbitrary: c c1)
  case (LVar x1)
    show ?case
      using LVar(1)[of x1] LVar(2)
      by auto
next
  case (LAbs A t)

    have "\<And>x. x \<in> FV t \<Longrightarrow> Suc c \<le> x \<Longrightarrow> - d \<le> int x \<and> int x + d \<ge> int (Suc c1)"
      proof -
        fix x
        assume hyps: "x\<in>FV t" "Suc c \<le> x"

        have "x\<noteq>0" using hyps(2) by auto

        then show "-d \<le> int x \<and> int x + d \<ge> int (Suc c1)"
          using LAbs(2)[of "x-1", unfolded FVE.simps image_iff, simplified] hyps
          by force
      qed
    then show ?case
      using LAbs(1)[of "Suc c" "Suc c1"]
            LAbs(3)
      by force
qed auto

lemma e_shift:
  "(\<And>x. x\<in>FVE t \<Longrightarrow> x\<ge> c \<Longrightarrow> int x \<ge> -d) \<Longrightarrow> e (shift_LE d c t) = shift_L d c (e t)"
proof (induction t arbitrary: c)
  case (LEAbs A t)
    have "\<And>x. x \<in> FVE t \<Longrightarrow> Suc c \<le> x \<Longrightarrow> - d \<le> int x"
      proof -
        fix x
        assume hyps: "x\<in>FVE t" "Suc c \<le> x"

        have "x\<noteq>0" using hyps(2) by auto

        then show "-d \<le> int x"
          using LEAbs(2)[of "x-1", unfolded FVE.simps image_iff, simplified] hyps
          by force
      qed
    then show ?case
      using LEAbs(1)[of "Suc c"]
      by auto
next
  case (SeqE t1 t2)
    have A:"(\<lambda>x. x - 1) ` (FV (shift_L 1 0 (e t2)) - {0}) = FV (e t2)"
      using FV_shift[of 1 0 "e t2"]
      by (fastforce simp add: Bex_def image_def)

    show ?case
      using shift_suc[of "e t2" c d 0]
            SeqE[unfolded FV_equiv[symmetric] e.simps FV.simps A]
      by force
qed auto

lemma shift_subst_suc:
  "j\<ge>c \<Longrightarrow> shift_L 1 c (subst_L j v t) = subst_L (Suc j) (shift_L 1 c v) (shift_L 1 c t)"
by (induction t arbitrary: c j v, auto simp: shift_suc)

lemma e_subst:
  "e (subst_LE j s t) = subst_L j (e s) (e t)"
by (induction t arbitrary: j s, auto simp: e_shift shift_subst_suc)

theorem e_surjective:
  fixes t::ltermI
  shows "\<exists>u. e u = t"
by (induction t)(blast intro:e.simps)+

method AppCase_m = ((match conclusion in "\<Gamma> \<turnstile>\<^sup>E LEApp e1 e2 |:| A" for \<Gamma> and e1 and e2 and A \<Rightarrow>
                  \<open>(auto intro!: "has_type_LE.intros")\<close>), auto)| (auto intro: "has_type_LE.intros")

method typeE_typeI_m =  ((match premises in H: "\<Gamma> \<turnstile> E |:| A" for \<Gamma> and E and A \<Rightarrow>
          \<open> insert has_type_L.simps[of \<Gamma> E A], auto \<close>), AppCase_m)

theorem typingE_equiv_typingI:
  "\<Gamma> \<turnstile>\<^sup>E t |:| A = \<Gamma> \<turnstile> e t |:| A"
proof
  show "\<Gamma> \<turnstile>\<^sup>E t |:| A \<Longrightarrow> \<Gamma> \<turnstile> e t |:| A"
    by (induction rule: has_type_LE.induct) (auto intro: "has_type_L.intros" has_type_LSeq)
next
  show "\<Gamma> \<turnstile> e t |:| A \<Longrightarrow> \<Gamma> \<turnstile>\<^sup>E t |:| A"
    proof (induction arbitrary: \<Gamma> A rule: e.induct)
      case (8 t1 t2 \<Gamma> A)
        note H=this
        obtain T11 where hyps:"\<Gamma> \<turnstile> LAbs Unit (shift_L 1 0 (e t2)) |:| T11 \<rightarrow> A" " \<Gamma> \<turnstile> e t1 |:| T11"
          using H(3)[simplified, unfolded has_type_L.simps[of \<Gamma> "e t1 ;; e t2" A, simplified]]
          by auto
        show ?case
          using hyps H(1,2)[of \<Gamma>]
                has_type_L.simps[of \<Gamma> "LAbs Unit (shift_L 1 0 (e t2))" "T11\<rightarrow>A", simplified]
                shift_down[of 0 Unit \<Gamma> "shift_L 1 0 (e t2)" A,
                            unfolded shift_shift_invert[of 1 0, simplified]]
                FV_shift[of 1 0] has_type_LESeqE[of \<Gamma> t1 t2 A]
          by auto
    qed typeE_typeI_m+
qed

theorem eval1_L_to_eval1_LE :
  fixes   t t'::ltermE and \<Gamma>::lcontext
  assumes "eval1_LE t t'"
  shows   "eval1_L (e t) (e t')"
using assms
proof (induction t t' arbitrary: A rule: eval1_LE.induct)
  case (eval1_LEApp_LEAbs v2 A1 t1)
    note hyp=this(1)
    have "0\<notin> FV (e t1) \<Longrightarrow>(\<And>x. x \<in> (if 0 \<in> FV (e t1) then FV (e t1) - {0} \<union>
                        FV (e (shift_LE 1 0 v2)) else FV (e t1)) \<Longrightarrow> 1 \<le> int x)"
      proof  (simp add: image_def Bex_def)
        fix x :: nat
        assume a1: "x \<in> FV (e t1)"
        assume "0 \<notin> FV (e t1)"
        then have "x \<noteq> 0"
          using a1 by meson
        then show "1 \<le> int x"
          by auto
      qed
    hence "\<And>x. x \<in> (if 0 \<in> FV (e t1) then FV (e t1) - {0} \<union> FV (e (shift_LE 1 0 v2)) else FV (e t1)) \<Longrightarrow> 1 \<le> int x"
      using FV_shift[of 1 0 "e v2"] e_shift[of v2 0 1, simplified]
      by (cases "0\<in> FV (e t1)") (force simp add: image_def Bex_def)

    then show ?case
      using e_shift[of v2 0 1, simplified]
            e_subst
            e_shift[of "(subst_LE 0 (shift_LE 1 0 v2) t1)" 0 "-1",
                    unfolded FV_equiv[symmetric] e_subst FV_subst, simplified]
            eval1_LApp_LAbs[OF hyp[unfolded value_equiv]]
      by auto
qed (auto intro: eval1_L.intros eval1_Lseq eval1_Lseq_next elim: has_type_LE.cases simp: value_equiv e_shift e_subst)

inductive BigS :: "ltermI\<Rightarrow>ltermI\<Rightarrow>bool" ("(_)\<Down>(_)" [151,150]200) where
 BigS_v         : "is_value_L v \<Longrightarrow> v \<Down> v" |
 BigS_App       : "s \<Down> LAbs A s' \<Longrightarrow> t \<Down> v2 \<Longrightarrow>
                    (shift_L (-1) 0 (subst_L 0 (shift_L 1 0 v2) s')) \<Down> v3 \<Longrightarrow> LApp s t \<Down> v3" |
 BigS_If_True   : "c \<Down> LTrue \<Longrightarrow> t1 \<Down> v1 \<Longrightarrow> t2 \<Down> v2 \<Longrightarrow> LIf c t1 t2 \<Down> v1" |
 BigS_If_False   : "c \<Down> LFalse \<Longrightarrow> t1 \<Down> v1 \<Longrightarrow> t2 \<Down> v2 \<Longrightarrow> LIf c t1 t2 \<Down> v2"

abbreviation normal::"ltermI \<Rightarrow> bool" where
  "normal s \<equiv> (\<forall>t'. \<not> eval1_L s t')"

abbreviation isNF :: "ltermI \<Rightarrow> ltermI \<Rightarrow> bool" where
  "isNF s t \<equiv> t \<Down> s"

lemma BigS_imp_normal:
  "s \<Down> t \<Longrightarrow> normal t"
proof (induction rule: BigS.induct)
  case (BigS_v v)
    thus ?case
      using eval1_L.simps[of v _] "is_value_L.simps"[of v]
      by blast
qed auto

lemma BigS_value:
  "s \<Down> v \<Longrightarrow> is_value_L v"
by (induction rule: BigS.induct)

lemma star_eval_LIF1:
  "star eval1_L c t \<Longrightarrow> star eval1_L (LIf c t1 t2) (LIf t t1 t2)"
by (induction rule: star.induct)(auto | meson eval1_LIf star.intros(2))+

lemma BigS_star_step:
 "s \<Down> t \<Longrightarrow> star eval1_L s t"
proof (induction rule: BigS.induct)
  case (BigS_App s A s' t v1 v2)
    have 1:"star eval1_L (LApp s t) (LApp (LAbs A s') t)"
      using BigS_App(4)
      by (induction rule: star.induct)(auto | meson eval1_LApp1 star.intros(2))+

    have 2:"star eval1_L (LApp (LAbs A s') t) (LApp (LAbs A s') v1)"
      using BigS_App(5)
       by (induction rule: star.induct)(auto | meson eval1_LApp2[OF is_value_L.intros(3)] star.intros(2))+

    have 3:"star eval1_L (LApp (LAbs A s') v1) v2"
      using BigS_value[OF BigS_App(2)] eval1_LApp_LAbs[of v1 A s']
            star.intros(2)[OF _ BigS_App(6)]
      by blast

    with 1 2 show ?case using star_trans[of "eval1_L"] by meson
next
  case (BigS_If_False c t1 v1 t2 v2)
    show ?case
      using star_eval_LIF1[OF BigS_If_False(4)]
            star.intros(2)[of "eval1_L", OF eval1_LIf_LFalse BigS_If_False(6)]
            star_trans[of "eval1_L"]
      by blast
next
  case (BigS_If_True c t1 v1 t2 v2)
    show ?case
      using star_eval_LIF1[OF BigS_If_True(4)]
            star.intros(2)[of "eval1_L", OF eval1_LIf_LTrue BigS_If_True(5)]
            star_trans[of "eval1_L"]
      by blast
qed auto

inductive BigSE :: "ltermE\<Rightarrow>ltermE\<Rightarrow>bool" ("(_)\<Down>\<^sub>E(_)" [151,150]200) where
 BigSE_v         : "is_value_LE v \<Longrightarrow> v \<Down>\<^sub>E v" |
 BigSE_App       : "s \<Down>\<^sub>E LEAbs A s' \<Longrightarrow> t \<Down>\<^sub>E v2 \<Longrightarrow>
                    (shift_LE (-1) 0 (subst_LE 0 (shift_LE 1 0 v2) s')) \<Down>\<^sub>E v3 \<Longrightarrow> LEApp s t \<Down>\<^sub>E v3" |
 BigSE_If_True    : "c \<Down>\<^sub>E LETrue \<Longrightarrow> t1 \<Down>\<^sub>E v1 \<Longrightarrow> t2 \<Down>\<^sub>E v2 \<Longrightarrow> LEIf c t1 t2 \<Down>\<^sub>E v1" |
 BigSE_If_False   : "c \<Down>\<^sub>E LEFalse \<Longrightarrow> t1 \<Down>\<^sub>E v1 \<Longrightarrow> t2 \<Down>\<^sub>E v2 \<Longrightarrow> LEIf c t1 t2 \<Down>\<^sub>E v2"|
 BigSE_Seq        : "t1 \<Down>\<^sub>E unitE \<Longrightarrow> t2 \<Down>\<^sub>E v1 \<Longrightarrow> SeqE t1 t2 \<Down>\<^sub>E v1"

abbreviation normalE::"ltermE \<Rightarrow> bool" where
  "normalE s \<equiv> (\<forall>t'. \<not> eval1_LE s t')"

abbreviation isNFE :: "ltermE \<Rightarrow> ltermE \<Rightarrow> bool" where
  "isNFE s t \<equiv> t \<Down>\<^sub>E s"

lemma BigSE_imp_normalE:
  "s \<Down>\<^sub>E t \<Longrightarrow> normalE t"
proof (induction rule: BigSE.induct)
  case (BigSE_v v)
    thus ?case
      using eval1_LE.simps[of v _] "is_value_LE.simps"[of v]
      by blast
qed auto

lemma BigSE_value:
  "s \<Down>\<^sub>E v \<Longrightarrow> is_value_LE v"
by (induction rule: BigSE.induct)

lemma star_eval_LEIF1:
  "star eval1_LE c t \<Longrightarrow> star eval1_LE (LEIf c t1 t2) (LEIf t t1 t2)"
by (induction rule: star.induct)(auto | meson eval1_LEIf star.intros(2))+

lemma BigSE_star_step:
 "s \<Down>\<^sub>E t \<Longrightarrow> star eval1_LE s t"
proof (induction rule: BigSE.induct)
  case (BigSE_App s A s' t v1 v2)
    have 1:"star eval1_LE (LEApp s t) (LEApp (LEAbs A s') t)"
      using BigSE_App(4)
      by (induction rule: star.induct)(auto | meson eval1_LEApp1 star.intros(2))+

    have 2:"star eval1_LE (LEApp (LEAbs A s') t) (LEApp (LEAbs A s') v1)"
      using BigSE_App(5)
       by (induction rule: star.induct)(auto | meson eval1_LEApp2[OF is_value_LE.intros(3)] star.intros(2))+

    have 3:"star eval1_LE (LEApp (LEAbs A s') v1) v2"
      using BigSE_value[OF BigSE_App(2)] eval1_LEApp_LEAbs[of v1 A s']
            star.intros(2)[OF _ BigSE_App(6)]
      by blast

    with 1 2 show ?case using star_trans[of "eval1_LE"] by meson
next
  case (BigSE_If_False c t1 v1 t2 v2)
    show ?case
      using star_eval_LEIF1[OF BigSE_If_False(4)]
            star.intros(2)[of "eval1_LE", OF eval1_LEIf_LFalse BigSE_If_False(6)]
            star_trans[of "eval1_LE"]
      by blast
next
  case (BigSE_If_True c t1 v1 t2 v2)
    show ?case
      using star_eval_LEIF1[OF BigSE_If_True(4)]
            star.intros(2)[of "eval1_LE", OF eval1_LEIf_LTrue BigSE_If_True(5)]
            star_trans[of "eval1_LE"]
      by blast
next
  case (BigSE_Seq t1 t2 v1)
    have "star eval1_LE (SeqE t1 t2) (SeqE unitE t2)"
      using BigSE_Seq(3)
      by (induction rule: star.induct)(auto | meson eval1_LE_E_Seq star.intros(2))+
    thus ?case
      using star.intros(2)[of "eval1_LE", OF eval1_LE_E_Seq_Next BigSE_Seq(4)]
            star_trans[of "eval1_LE"]
      by meson
qed auto

end


(*  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 \<le> length yl"
shows "prefixeq 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 "prefixeq xl yl \<or> prefixeq yl xl"
using shift_prefix[OF assms] apply(cases "length xl \<le> length yl")
by (metis, metis assms nat_le_linear shift_prefix)

section{* Linear temporal logic *}

(* Propositional connectives: *)
abbreviation (input) IMPL (infix "impl" 60)
where "\<phi> impl \<psi> \<equiv> \<lambda> xs. \<phi> xs \<longrightarrow> \<psi> xs"

abbreviation (input) OR (infix "or" 60)
where "\<phi> or \<psi> \<equiv> \<lambda> xs. \<phi> xs \<or> \<psi> xs"

abbreviation (input) AND (infix "aand" 60)
where "\<phi> aand \<psi> \<equiv> \<lambda> xs. \<phi> xs \<and> \<psi> xs"

abbreviation (input) "not \<phi> \<equiv> \<lambda> xs. \<not> \<phi> xs"

abbreviation (input) "true \<equiv> \<lambda> xs. True"

abbreviation (input) "false \<equiv> \<lambda> xs. False"

lemma impl_not_or: "\<phi> impl \<psi> = (not \<phi>) or \<psi>"
by blast

lemma not_or: "not (\<phi> or \<psi>) = (not \<phi>) aand (not \<psi>)"
by blast

lemma not_aand: "not (\<phi> aand \<psi>) = (not \<phi>) or (not \<psi>)"
by blast

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

(* Temporal (LTL) connectives: *)
fun holds where "holds P xs \<longleftrightarrow> P (shd xs)"
fun nxt where "nxt \<phi> xs = \<phi> (stl xs)"

definition "HLD s = holds (\<lambda>x. x \<in> s)"

abbreviation HLD_nxt (infixr "\<cdot>" 65) where
  "s \<cdot> P \<equiv> HLD s aand nxt P"

inductive ev for \<phi> where
base: "\<phi> xs \<Longrightarrow> ev \<phi> xs"
|
step: "ev \<phi> (stl xs) \<Longrightarrow> ev \<phi> xs"

coinductive alw for \<phi> where
alw: "\<lbrakk>\<phi> xs; alw \<phi> (stl xs)\<rbrakk> \<Longrightarrow> alw \<phi> xs"

(* weak until: *)
coinductive UNTIL (infix "until" 60) for \<phi> \<psi> where
base: "\<psi> xs \<Longrightarrow> (\<phi> until \<psi>) xs"
|
step: "\<lbrakk>\<phi> xs; (\<phi> until \<psi>) (stl xs)\<rbrakk> \<Longrightarrow> (\<phi> until \<psi>) xs"

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

lemma holds_aand:
"(holds P aand holds Q) steps \<longleftrightarrow> holds (\<lambda> step. P step \<and> Q step) steps" by auto

lemma HLD_iff: "HLD s \<omega> \<longleftrightarrow> shd \<omega> \<in> s"
  by (simp add: HLD_def)

lemma HLD_Stream[simp]: "HLD X (x ## \<omega>) \<longleftrightarrow> x \<in> X"
  by (simp add: HLD_iff)

lemma nxt_mono:
assumes nxt: "nxt \<phi> xs" and 0: "\<And> xs. \<phi> xs \<Longrightarrow> \<psi> xs"
shows "nxt \<psi> xs"
using assms by auto

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

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

lemma alw_coinduct[consumes 1, case_names alw stl]:
  "X x \<Longrightarrow> (\<And>x. X x \<Longrightarrow> \<phi> x) \<Longrightarrow> (\<And>x. X x \<Longrightarrow> \<not> alw \<phi> (stl x) \<Longrightarrow> X (stl x)) \<Longrightarrow> alw \<phi> x"
  using alw.coinduct[of X x \<phi>] by auto

lemma ev_mono:
assumes ev: "ev \<phi> xs" and 0: "\<And> xs. \<phi> xs \<Longrightarrow> \<psi> xs"
shows "ev \<psi> xs"
using ev by induct (auto intro: ev.intros simp: 0)

lemma alw_mono:
assumes alw: "alw \<phi> xs" and 0: "\<And> xs. \<phi> xs \<Longrightarrow> \<psi> xs"
shows "alw \<psi> xs"
using alw by coinduct (auto elim: alw.cases simp: 0)

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

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

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

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

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

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

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

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

lemma ev_shift:
assumes "ev \<phi> xs"
shows "ev \<phi> (xl @- xs)"
using assms by (induct xl) (auto intro: ev.intros)

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

lemma alw_ev_shift: "alw \<phi> xs1 \<Longrightarrow> ev (alw \<phi>) (xl @- xs1)"
by (auto intro: ev_shift ev.intros)

lemma alw_shift:
assumes "alw \<phi> (xl @- xs)"
shows "alw \<phi> xs"
using assms by (induct xl) (auto elim: alw.cases)

lemma ev_ex_nxt:
assumes "ev \<phi> xs"
shows "\<exists> n. (nxt ^^ n) \<phi> 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) \<phi> (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 \<phi> xs"  shows "alw \<phi> (sdrop n xs)"
by (metis alw_shift assms stake_sdrop)

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

definition "wait \<phi> xs \<equiv> LEAST n. (nxt ^^ n) \<phi> xs"

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

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

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

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

lemma nxt_ev: "(nxt ^^ n) \<phi> xs \<Longrightarrow> ev \<phi> xs"
by (induct n arbitrary: xs) (auto intro: ev.intros)

lemma not_ev: "not (ev \<phi>) = alw (not \<phi>)"
proof(rule ext, safe)
  fix xs assume "not (ev \<phi>) xs" thus "alw (not \<phi>) xs"
  by (coinduct) (auto intro: ev.intros)
next
  fix xs assume "ev \<phi> xs" and "alw (not \<phi>) xs" thus False
  by (induct) (auto elim: alw.cases)
qed

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

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

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

lemma alw_ev_sdrop:
assumes "alw (ev \<phi>) (sdrop m xs)"
shows "alw (ev \<phi>) 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 \<phi>) xs"  shows "alw (ev \<phi>) xs"
using assms apply induct
  apply (metis (full_types) alw_mono ev.base)
  by (metis alw alw_nxt ev.step)

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

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

lemma ev_alw_aand:
assumes \<phi>: "ev (alw \<phi>) xs" and \<psi>: "ev (alw \<psi>) xs"
shows "ev (alw (\<phi> aand \<psi>)) xs"
proof-
  obtain xl xs1 where xs1: "xs = xl @- xs1" and \<phi>\<phi>: "alw \<phi> xs1"
  using \<phi> by (metis ev_imp_shift)
  moreover obtain yl ys1 where xs2: "xs = yl @- ys1" and \<psi>\<psi>: "alw \<psi> ys1"
  using \<psi> by (metis ev_imp_shift)
  ultimately have 0: "xl @- xs1 = yl @- ys1" by auto
  hence "prefixeq xl yl \<or> prefixeq yl xl" using shift_prefix_cases by auto
  thus ?thesis proof
    assume "prefixeq xl yl"
    then obtain yl1 where yl: "yl = xl @ yl1" by (elim prefixeqE)
    have xs1': "xs1 = yl1 @- ys1" using 0 unfolding yl by simp
    have "alw \<phi> ys1" using \<phi>\<phi> unfolding xs1' by (metis alw_shift)
    hence "alw (\<phi> aand \<psi>) ys1" using \<psi>\<psi> unfolding alw_aand by auto
    thus ?thesis unfolding xs2 by (auto intro: alw_ev_shift)
  next
    assume "prefixeq yl xl"
    then obtain xl1 where xl: "xl = yl @ xl1" by (elim prefixeqE)
    have ys1': "ys1 = xl1 @- xs1" using 0 unfolding xl by simp
    have "alw \<psi> xs1" using \<psi>\<psi> unfolding ys1' by (metis alw_shift)
    hence "alw (\<phi> aand \<psi>) xs1" using \<phi>\<phi> 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 \<phi>) xs" and "alw (alw \<phi> impl ev \<psi>) xs"
shows "ev \<psi> xs"
using assms by induct (auto intro: ev.intros elim: alw.cases)

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

lemma alw_alw_impl_ev:
"alw (alw \<phi> impl ev \<psi>) = (ev (alw \<phi>) impl alw (ev \<psi>))" (is "?A = ?B")
proof-
  {fix xs assume "?A xs \<and> ev (alw \<phi>) xs" hence "alw (ev \<psi>) xs"
   apply coinduct using ev_nxt by (auto elim: ev_alw_alw_impl alw.cases intro: ev.intros)
  }
  moreover
  {fix xs assume "?B xs" hence "?A xs"
   apply coinduct by (auto elim: alw.cases intro: ev.intros)
  }
  ultimately show ?thesis by blast
qed

lemma ev_alw_impl:
assumes "ev \<phi> xs" and "alw (\<phi> impl \<psi>) xs"  shows "ev \<psi> xs"
using assms by induct (auto intro: ev.intros elim: alw.cases)

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

lemma alw_mp:
assumes "alw \<phi> xs" and "alw (\<phi> impl \<psi>) xs"
shows "alw \<psi> xs"
proof-
  {assume "alw \<phi> xs \<and> alw (\<phi> impl \<psi>) xs" hence ?thesis
   apply coinduct by (auto elim: alw.cases)
  }
  thus ?thesis using assms by auto
qed

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

lemma alw_impl_ev_alw:
assumes "alw (\<phi> impl ev \<psi>) xs"
shows "alw (ev \<phi> impl ev \<psi>) xs"
using assms by coinduct (auto elim: alw.cases dest: ev_alw_impl intro: ev.intros)

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

(* LTL as a program logic: *)
lemma alw_invar:
assumes "\<phi> xs" and "alw (\<phi> impl nxt \<phi>) xs"
shows "alw \<phi> xs"
proof-
  {assume "\<phi> xs \<and> alw (\<phi> impl nxt \<phi>) xs" hence ?thesis
   apply coinduct by(auto elim: alw.cases)
  }
  thus ?thesis using assms by auto
qed

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

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

inductive ev_at :: "('a stream \<Rightarrow> bool) \<Rightarrow> nat \<Rightarrow> 'a stream \<Rightarrow> bool" for P :: "'a stream \<Rightarrow> bool" where
  base: "P \<omega> \<Longrightarrow> ev_at P 0 \<omega>"
| step:"\<not> P \<omega> \<Longrightarrow> ev_at P n (stl \<omega>) \<Longrightarrow> ev_at P (Suc n) \<omega>"

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

lemma ev_at_imp_snth: "ev_at P n \<omega> \<Longrightarrow> P (sdrop n \<omega>)"
  by (induction n arbitrary: \<omega>) auto

lemma ev_at_HLD_imp_snth: "ev_at (HLD X) n \<omega> \<Longrightarrow> \<omega> !! n \<in> X"
  by (auto dest!: ev_at_imp_snth simp: HLD_iff)

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

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

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

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

lemma ev_iff_ev_at_unqiue: "ev P \<omega> \<longleftrightarrow> (\<exists>!n. ev_at P n \<omega>)"
  by (auto intro: ev_at_unique simp: ev_iff_ev_at)

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

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

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

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

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

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

lemma ev_False: "ev (\<lambda>x. False) \<omega> \<longleftrightarrow> False"
proof
  assume "ev (\<lambda>x. False) \<omega>" then show False
    by induct auto
qed auto

lemma alw_False: "alw (\<lambda>x. False) \<omega> \<longleftrightarrow> False"
  by auto

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

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

lemma infinite_iff_alw_ev: "infinite {m. P (sdrop m \<omega>)} \<longleftrightarrow> alw (ev P) \<omega>"
  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: "\<And>s. f (stl s) = stl (f s)"
  shows "alw P (f s) \<longleftrightarrow> alw (\<lambda>x. P (f x)) s"
proof
  assume "alw P (f s)" then show "alw (\<lambda>x. P (f x)) s"
    by (coinduction arbitrary: s rule: alw_coinduct)
       (auto simp: stl)
next
  assume "alw (\<lambda>x. P (f x)) s" then show "alw P (f s)"
    by (coinduction arbitrary: s rule: alw_coinduct) (auto simp: stl[symmetric])
qed

lemma ev_inv:
  assumes stl: "\<And>s. f (stl s) = stl (f s)"
  shows "ev P (f s) \<longleftrightarrow> ev (\<lambda>x. P (f x)) s"
proof
  assume "ev P (f s)" then show "ev (\<lambda>x. P (f x)) s"
    by (induction "f s" arbitrary: s) (auto simp: stl)
next
  assume "ev (\<lambda>x. P (f x)) s" then show "ev P (f s)"
    by induction (auto simp: stl[symmetric])
qed

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

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

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

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

lemma alwD: "alw P x \<Longrightarrow> P x"
  by auto

lemma alw_alwD: "alw P \<omega> \<Longrightarrow> alw (alw P) \<omega>"
  by simp

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

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

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

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

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

text {* Strong until *}

inductive suntil (infix "suntil" 60) for \<phi> \<psi> where
  base: "\<psi> \<omega> \<Longrightarrow> (\<phi> suntil \<psi>) \<omega>"
| step: "\<phi> \<omega> \<Longrightarrow> (\<phi> suntil \<psi>) (stl \<omega>) \<Longrightarrow> (\<phi> suntil \<psi>) \<omega>"

inductive_simps suntil_Stream: "(\<phi> suntil \<psi>) (x ## s)"

lemma suntil_induct_strong[consumes 1, case_names base step]:
  "(\<phi> suntil \<psi>) x \<Longrightarrow>
    (\<And>\<omega>. \<psi> \<omega> \<Longrightarrow> P \<omega>) \<Longrightarrow>
    (\<And>\<omega>. \<phi> \<omega> \<Longrightarrow> \<not> \<psi> \<omega> \<Longrightarrow> (\<phi> suntil \<psi>) (stl \<omega>) \<Longrightarrow> P (stl \<omega>) \<Longrightarrow> P \<omega>) \<Longrightarrow> P x"
  using suntil.induct[of \<phi> \<psi> x P] by blast

lemma ev_suntil: "(\<phi> suntil \<psi>) \<omega> \<Longrightarrow> ev \<psi> \<omega>"
  by (induct rule: suntil.induct) (auto intro: ev.intros)

lemma suntil_inv:
  assumes stl: "\<And>s. f (stl s) = stl (f s)"
  shows "(P suntil Q) (f s) \<longleftrightarrow> ((\<lambda>x. P (f x)) suntil (\<lambda>x. Q (f x))) s"
proof
  assume "(P suntil Q) (f s)" then show "((\<lambda>x. P (f x)) suntil (\<lambda>x. Q (f x))) s"
    by (induction "f s" arbitrary: s) (auto simp: stl intro: suntil.intros)
next
  assume "((\<lambda>x. P (f x)) suntil (\<lambda>x. Q (f x))) s" then show "(P suntil Q) (f s)"
    by induction (auto simp: stl[symmetric] intro: suntil.intros)
qed

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

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

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

lemma suntil_cong:
  "alw P \<omega> \<Longrightarrow> (\<And>\<omega>. P \<omega> \<Longrightarrow> Q1 \<omega> \<longleftrightarrow> Q2 \<omega>) \<Longrightarrow> (\<And>\<omega>. P \<omega> \<Longrightarrow> R1 \<omega> \<longleftrightarrow> R2 \<omega>) \<Longrightarrow>
    (Q1 suntil R1) \<omega> \<longleftrightarrow> (Q2 suntil R2) \<omega>"
  using suntil_mono[of P Q1 Q2 R1 R2 \<omega>] suntil_mono[of P Q2 Q1 R2 R1 \<omega>] by auto

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

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

lemma suntil_lfp: "(\<phi> suntil \<psi>) = lfp (\<lambda>P s. \<psi> s \<or> (\<phi> s \<and> P (stl s)))"
  by (simp add: suntil_def)

lemma sfilter_P[simp]: "P (shd s) \<Longrightarrow> 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]: "\<not> P (shd s) \<Longrightarrow> 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' \<longleftrightarrow>
    P x \<and> (not (holds P) suntil (HLD {x} aand nxt (\<lambda>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)) \<omega> \<Longrightarrow> \<omega> \<in> streams A \<Longrightarrow> sfilter P \<omega> \<in> streams {x\<in>A. P x}"
proof (coinduction arbitrary: \<omega>)
  case (streams \<omega>)
  then have "ev (holds P) \<omega>" 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) \<longleftrightarrow> alw (\<lambda>x. Q (sfilter P x)) s"
proof
  assume "alw Q (sfilter P s)" with * show "alw (\<lambda>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 (\<lambda>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) \<longleftrightarrow> ev (\<lambda>x. Q (sfilter P x)) s"
proof
  assume "ev Q (sfilter P s)" from this * show "ev (\<lambda>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 (\<lambda>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) \<longleftrightarrow> (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:
  "(\<phi> suntil (\<phi> aand nxt \<psi>)) \<omega> \<longleftrightarrow> (\<phi> aand nxt (\<phi> suntil \<psi>)) \<omega>"
proof
  assume "(\<phi> suntil (\<phi> aand nxt \<psi>)) \<omega>" then show "(\<phi> aand nxt (\<phi> suntil \<psi>)) \<omega>"
    by induction (auto intro: suntil.intros)
next
  assume "(\<phi> aand nxt (\<phi> suntil \<psi>)) \<omega>"
  then have "(\<phi> suntil \<psi>) (stl \<omega>)" "\<phi> \<omega>"
    by auto
  then show "(\<phi> suntil (\<phi> aand nxt \<psi>)) \<omega>"
    by (induction "stl \<omega>" arbitrary: \<omega>)
       (auto elim: suntil.cases intro: suntil.intros)
qed

lemma alw_sconst: "alw P (sconst x) \<longleftrightarrow> 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) \<longleftrightarrow> P (sconst x)"
proof
  assume "ev P (sconst x)" then show "P (sconst x)"
    by (induction "sconst x") auto
qed auto

lemma suntil_sconst: "(\<phi> suntil \<psi>) (sconst x) \<longleftrightarrow> \<psi> (sconst x)"
proof
  assume "(\<phi> suntil \<psi>) (sconst x)" then show "\<psi> (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)

end