theory Sat
  imports Monitor
begin

lemma ex_prefix_of': "\<exists>\<sigma>. prefix_of (\<pi> :: ('a \<Rightarrow> 'b set) prefix) \<sigma> \<and> (\<forall>x. \<forall>i \<ge> plen \<pi>. \<Gamma> \<sigma> i x = {})"
proof (transfer, intro bexI CollectI conjI)
  fix p :: "(('a \<Rightarrow> 'b set) \<times> nat) list"
  assume *: "sorted (map snd p)"
  let ?\<sigma> = "p @- smap (Pair (\<lambda>_::'a. {} :: 'b set)) (fromN (snd (last p)))"
  show "stake (length p) ?\<sigma> = p" by (simp add: stake_shift)
  have le_last: "snd (p ! i) \<le> snd (last p)" if "i < length p" for i
    using sorted_nth_mono[OF *, of i "length p - 1"] that
    by (cases p) (auto simp: last_conv_nth nth_Cons')
  with * show "ssorted (smap snd ?\<sigma>)"
    by (force simp: ssorted_iff_mono sorted_iff_nth_mono shift_snth)
  show "sincreasing (smap snd ?\<sigma>)"
  proof (rule sincreasingI)
    fix x
    have "x < smap snd ?\<sigma> !! Suc (length p + x)"
      by simp (metis Suc_pred add.commute diff_Suc_Suc length_greater_0_conv less_add_Suc1 less_diff_conv)
    then show "\<exists>i. x < smap snd ?\<sigma> !! i" ..
  qed
  show "\<forall>x i. length p \<le> i \<longrightarrow> fst (?\<sigma> !! i) x = {}"
    by auto
qed

lemma smap2_const[simp]: "smap2 (\<lambda>_. f) s t = smap f t"
  by (coinduction arbitrary: s t) auto

lift_definition map_\<Gamma>i :: "(nat \<Rightarrow> 'a \<Rightarrow> 'b) \<Rightarrow> 'a trace \<Rightarrow> 'b trace" is
  "\<lambda>f s. smap2 (\<lambda>i (x, tau). (f i x, tau)) nats s"
  by (auto simp: stream.map_comp prod.case_eq_if cong: stream.map_cong)

lemma \<tau>_map_\<Gamma>i[simp]: "\<tau> (map_\<Gamma>i f \<sigma>) = \<tau> \<sigma>"
  by transfer (auto split: prod.splits)

lemma \<Gamma>_map_\<Gamma>i: "\<Gamma> (map_\<Gamma>i f \<sigma>) i = f i (\<Gamma> \<sigma> i)"
  by transfer (auto split: prod.splits)

lemma map_\<Gamma>i_id[simp]: "map_\<Gamma>i (\<lambda>i x. x) \<sigma> = \<sigma>"
  by transfer (auto simp: stream.map_id)

lemma map_\<Gamma>i_comp[simp]: "map_\<Gamma>i f (map_\<Gamma>i g \<sigma>) = map_\<Gamma>i (\<lambda>i. f i o g i) \<sigma>"
  by transfer (auto simp: stream_eq_iff split: prod.splits)

lemma map_\<Gamma>_map_\<Gamma>i[simp]: "map_\<Gamma> f (map_\<Gamma>i g \<sigma>) = map_\<Gamma>i (\<lambda>i. f o g i) \<sigma>"
  by transfer (auto simp: stream_eq_iff split: prod.splits)

lemma map_\<Gamma>i_map_\<Gamma>[simp]: "map_\<Gamma>i f (map_\<Gamma> g \<sigma>) = map_\<Gamma>i (\<lambda>i. f i o g) \<sigma>"
  by transfer (auto simp: stream_eq_iff split: prod.splits)

lemma map_\<Gamma>i_map_\<Gamma>i_cong: "(\<And>i. f i (\<Gamma> \<sigma> i) = g i (\<Gamma> \<sigma> i))\<Longrightarrow> map_\<Gamma>i f \<sigma> = map_\<Gamma>i g \<sigma>"
  by transfer (auto simp: stream_eq_iff split_beta)

lemma map_\<Gamma>i_map_\<Gamma>_cong: "(\<And>i. f i (\<Gamma> \<sigma> i) = g (\<Gamma> \<sigma> i))\<Longrightarrow> map_\<Gamma>i f \<sigma> = map_\<Gamma> g \<sigma>"
  by transfer (auto simp: stream_eq_iff split_beta)

abbreviation update_\<Gamma> where "update_\<Gamma> \<sigma> pn f \<equiv> map_\<Gamma>i (\<lambda>j db. db(pn := f j)) \<sigma>"

nonterminal upd\<Gamma>binds and upd\<Gamma>bind

syntax
  "_upd\<Gamma>bind" :: "'a \<Rightarrow> 'a \<Rightarrow> upd\<Gamma>bind"             ("(2_ \<Rrightarrow>/ _)")
  ""         :: "upd\<Gamma>bind \<Rightarrow> upd\<Gamma>binds"             ("_")
  "_upd\<Gamma>binds":: "upd\<Gamma>bind \<Rightarrow> upd\<Gamma>binds \<Rightarrow> upd\<Gamma>binds" ("_,/ _")
  "_Upd\<Gamma>ate"  :: "'a \<Rightarrow> upd\<Gamma>binds \<Rightarrow> 'a"            ("_/'((_)')" [1000, 0] 900)

translations
  "_Upd\<Gamma>ate f (_upd\<Gamma>binds b bs)" \<rightleftharpoons> "_Upd\<Gamma>ate (_Upd\<Gamma>ate f b) bs"
  "f(x\<Rrightarrow>y)" \<rightleftharpoons> "CONST update_\<Gamma> f x y"

context begin

fun preds :: "'t Formula.formula \<Rightarrow> (Formula.name \<times> nat) set" where
   "preds (Formula.Eq t1 t2) = {}"
|  "preds (Formula.Less t1 t2) = {}"
|  "preds (Formula.LessEq t1 t2) = {}"
|  "preds (Formula.Pred e ts) = {(e, length ts)}"
|  "preds (Formula.Let e \<phi> \<psi>) = (preds \<phi> \<union> preds \<psi>)"
     \<comment> \<open>(let en = (e, Formula.nfv \<phi>); p\<psi> = preds \<psi> in (p\<psi> - {en} \<union> (if en \<in> p\<psi> then preds \<phi> else {})))\<close>
|  "preds (Formula.LetPast e \<phi> \<psi>) = (preds \<phi> \<union> preds \<psi>)"
     \<comment> \<open>(let en = (e, Formula.nfv \<phi>); p\<psi> = preds \<psi> in (p\<psi> \<union> (if en \<in> p\<psi> then preds \<phi> else {})) - {en})\<close>
|  "preds (Formula.Neg \<phi>) = preds \<phi>"
|  "preds (Formula.Or \<phi> \<psi>) = (preds \<phi> \<union> preds \<psi>)"
|  "preds (Formula.And \<phi> \<psi>) = (preds \<phi> \<union> preds \<psi>)"
|  "preds (Formula.Ands l) = (\<Union>\<phi>\<in>set l. preds \<phi>)"
|  "preds (Formula.Exists ty \<phi>) = preds \<phi>"
|  "preds (Formula.Agg y \<omega> tys f \<phi>) = preds \<phi>"
|  "preds (Formula.Prev I \<phi>) = preds \<phi>"
|  "preds (Formula.Next I \<phi>) = preds \<phi>"
|  "preds (Formula.Since \<phi> I \<psi>) = (preds \<phi> \<union> preds \<psi>)"
|  "preds (Formula.Until \<phi> I \<psi>) = (preds \<phi> \<union> preds \<psi>)"
|  "preds (Formula.MatchP I r) = (\<Union>\<phi>\<in>Regex.atms r. preds \<phi>)"
|  "preds (Formula.MatchF I r) =  (\<Union>\<phi>\<in>Regex.atms r. preds \<phi>)"
|  "preds (Formula.TP t) = {}"
|  "preds (Formula.TS t) = {}"

subsection \<open>Syntax and semantics\<close>

qualified type_synonym database = "Formula.name \<times> nat \<Rightarrow> Formula.env set"
qualified type_synonym prefix = "database prefix"
qualified type_synonym trace = "database trace"

fun letpast_sat where
  "letpast_sat sat (i::nat) = sat (\<lambda>j. if j < i then letpast_sat sat j else {}) i"
declare letpast_sat.simps[simp del]

lemma subst_letpast_sat:
  "(\<And>X v j. j \<le> i \<Longrightarrow> f X j = g X j) \<Longrightarrow> letpast_sat f i = letpast_sat g i"
  by (induct f i rule: letpast_sat.induct) (subst (1 2) letpast_sat.simps, auto cong: if_cong)

fun sat :: "trace \<Rightarrow> Formula.env \<Rightarrow> nat \<Rightarrow> ty Formula.formula \<Rightarrow> bool" where
  "sat \<sigma> v i (Formula.Pred r ts) = (map (Formula.eval_trm v) ts \<in> \<Gamma> \<sigma> i (r, length ts))"
| "sat \<sigma> v i (Formula.Let p \<phi> \<psi>) =
    (let pn = (p, Formula.nfv \<phi>) in
    sat (\<sigma>(pn \<Rrightarrow> \<lambda>j. {w. sat \<sigma> w j \<phi> \<and> length w = snd pn})) v i \<psi>)"
| "sat \<sigma> v i (Formula.LetPast p \<phi> \<psi>) =
    (let pn = (p, Formula.nfv \<phi>) in
    sat (\<sigma>(pn \<Rrightarrow> letpast_sat (\<lambda>X k. {u. sat (\<sigma>(pn \<Rrightarrow> X)) u k \<phi> \<and> length u = snd pn}))) v i \<psi>)"
| "sat \<sigma> v i (Formula.Eq t1 t2) = (Formula.eval_trm v t1 = Formula.eval_trm v t2)"
| "sat \<sigma> v i (Formula.Less t1 t2) = (Formula.eval_trm v t1 < Formula.eval_trm v t2)"
| "sat \<sigma> v i (Formula.LessEq t1 t2) = (Formula.eval_trm v t1 \<le> Formula.eval_trm v t2)"
| "sat \<sigma> v i (Formula.Neg \<phi>) = (\<not> sat \<sigma> v i \<phi>)"
| "sat \<sigma> v i (Formula.Or \<phi> \<psi>) = (sat \<sigma> v i \<phi> \<or> sat \<sigma> v i \<psi>)"
| "sat \<sigma> v i (Formula.And \<phi> \<psi>) = (sat \<sigma> v i \<phi> \<and> sat \<sigma> v i \<psi>)"
| "sat \<sigma> v i (Formula.Ands l) = (\<forall>\<phi> \<in> set l. sat \<sigma> v i \<phi>)"
| "sat \<sigma> v i (Formula.Exists ty \<phi>) = (\<exists>z. sat \<sigma> (z # v) i \<phi>)"
| "sat \<sigma> v i (Formula.Agg y \<omega> tys f \<phi>) =
    (let M = {(x, ecard Zs) | x Zs. Zs = {zs. length zs = length tys \<and> sat \<sigma> (zs @ v) i \<phi> \<and> Formula.eval_trm (zs @ v) f = x} \<and> Zs \<noteq> {}}
    in (M = {} \<longrightarrow> fv \<phi> \<subseteq> {0..<length tys}) \<and> v ! y = eval_agg_op \<omega> M)"
| "sat \<sigma> v i (Formula.Prev I \<phi>) = (case i of 0 \<Rightarrow> False | Suc j \<Rightarrow> mem I (\<tau> \<sigma> i - \<tau> \<sigma> j) \<and> sat \<sigma> v j \<phi>)"
| "sat \<sigma> v i (Formula.Next I \<phi>) = (mem I ((\<tau> \<sigma> (Suc i) - \<tau> \<sigma> i)) \<and> sat \<sigma> v (Suc i) \<phi>)"
| "sat \<sigma> v i (Formula.Since \<phi> I \<psi>) = (\<exists>j\<le>i. mem I (\<tau> \<sigma> i - \<tau> \<sigma> j) \<and> sat \<sigma> v j \<psi> \<and> (\<forall>k \<in> {j <.. i}. sat \<sigma> v k \<phi>))"
| "sat \<sigma> v i (Formula.Until \<phi> I \<psi>) = (\<exists>j\<ge>i. mem I (\<tau> \<sigma> j - \<tau> \<sigma> i) \<and> sat \<sigma> v j \<psi> \<and> (\<forall>k \<in> {i ..< j}. sat \<sigma> v k \<phi>))"
| "sat \<sigma> v i (Formula.MatchP I r) = (\<exists>j\<le>i. mem I (\<tau> \<sigma> i - \<tau> \<sigma> j) \<and> Regex.match (sat \<sigma> v) r j i)"
| "sat \<sigma> v i (Formula.MatchF I r) = (\<exists>j\<ge>i. mem I (\<tau> \<sigma> j - \<tau> \<sigma> i) \<and> Regex.match (sat \<sigma> v) r i j)"
| "sat \<sigma> v i (Formula.TP t) = (Formula.eval_trm v t = EInt (integer_of_nat i))"
| "sat \<sigma> v i (Formula.TS t) = (Formula.eval_trm v t = EInt (integer_of_nat (\<tau> \<sigma> i)))"

end

definition "convert \<sigma> V = map_\<Gamma>i (\<lambda>i db pn. case V pn of None \<Rightarrow> {w. (fst pn, w) \<in> db \<and> length w = snd pn}
  | Some X \<Rightarrow> {w. X w i \<and> length w = snd pn}) \<sigma>"

abbreviation to_db where "to_db A db \<equiv> \<Union>(p,n) \<in> A. Pair p ` {v \<in> db (p, n). length v = n}"
definition "unconvert A \<sigma> = map_\<Gamma> (to_db A) \<sigma>"
definition "punconvert A \<pi> = pmap_\<Gamma> (to_db A) \<pi>"

lemma prefix_of_unconvert: "prefix_of \<pi> \<sigma> \<Longrightarrow> prefix_of (punconvert A \<pi>) (unconvert A \<sigma>)"
  unfolding unconvert_def punconvert_def by transfer auto

lemma plen_punconvert[simp]: "plen (punconvert A \<pi>) = plen \<pi>"
  unfolding punconvert_def by transfer auto

lemma pts_punconvert[simp]: "pts (punconvert A \<pi>) = pts \<pi>"
  unfolding punconvert_def by transfer auto

abbreviation fix_length where "fix_length A X \<equiv> (\<lambda>(a, n). if (a, n) \<in> A then X (a, n) \<inter> {w. length w = n} else {})"

lemma unconvert_convert: "unconvert UNIV (convert \<sigma> Map.empty) = \<sigma>"
  unfolding convert_def unconvert_def by (force simp: o_def intro!: trans[OF map_\<Gamma>i_map_\<Gamma>_cong[of _ _ id]])

definition "unconvertV X \<sigma> p = (if p \<in> X then Some (\<lambda>v i. v \<in> \<Gamma> \<sigma> i p \<and> length v = snd p) else None)"

lemma unconvertV_empty[simp]: "unconvertV {} \<sigma> = Map.empty"
  unfolding unconvertV_def by auto

lemma convert_unconvert: "convert (unconvert A \<sigma>) (unconvertV X \<sigma>) = map_\<Gamma> (fix_length (A \<union> X)) \<sigma>"
  unfolding convert_def unconvert_def unconvertV_def
  by (force intro!: map_\<Gamma>i_map_\<Gamma>_cong simp: fun_eq_iff)

lemma \<tau>_convert[simp]: "\<tau> (convert \<sigma> V) = \<tau> \<sigma>"
  unfolding convert_def by simp

lemma \<tau>_unconvert[simp]: "\<tau> (unconvert A \<sigma>) = \<tau> \<sigma>"
  unfolding unconvert_def by auto

lemma map_\<Gamma>_update_\<Gamma>: "(map_\<Gamma> f \<sigma>)(pn \<Rrightarrow> X) = map_\<Gamma>i (\<lambda>i x. (f x)(pn := X i)) \<sigma>"
  by (auto simp: o_def)

lemma convert_fun_upd: "convert \<sigma> (V(pn \<mapsto> X)) = (convert \<sigma> V)(pn \<Rrightarrow> \<lambda>j. {w. X w j \<and> length w = snd pn})"
  unfolding convert_def
  by (auto simp: fun_eq_iff intro!: arg_cong[of _ _ "\<lambda>f. map_\<Gamma>i f \<sigma>"])

lemma letpast_sat_alt:
  "snd pn = n \<Longrightarrow> letpast_sat (\<lambda>X j. {w. sat (\<sigma>(pn \<Rrightarrow> X)) w j \<phi> \<and> length w = n})
  = (\<lambda>i. {v. Formula.letpast_sat (\<lambda>X w j. sat (\<sigma>(pn \<Rrightarrow> \<lambda>k. {u. X u k \<and> length u = n})) w j \<phi>) v i \<and> length v = n})"
  apply (rule ext)
  subgoal for i
    apply (induction i rule: less_induct)
    apply (subst Sat.letpast_sat.simps)
    apply (subst Formula.letpast_sat.simps)
    apply (intro Collect_cong conj_cong[OF _ refl])
    apply (subst ext[where f="\<lambda>j db. db(pn := if j < _ then _ j else {})"])
     apply (rule ext)
     apply (rule arg_cong[where f="fun_upd _ pn"])
     apply (rule if_cong[OF refl _ refl])
     apply assumption
    apply (rule arg_cong[where f="\<lambda>g. sat (_(pn \<Rrightarrow> g)) _ _ _"])
    by (simp add: fun_eq_iff)
  done

lemma sat_convert: "Formula.sat \<sigma> V v i \<phi> \<longleftrightarrow> sat (convert \<sigma> V) v i \<phi>"
proof (induct \<phi> arbitrary: V v i)
  case (Pred e ts)
  then show ?case
    by (auto simp: convert_def \<Gamma>_map_\<Gamma>i split: option.splits)
next
  case (Let p \<phi> \<psi>)
  then show ?case
    by (simp del: fun_upd_apply add: convert_fun_upd)
next
  case (LetPast p \<phi> \<psi>)
  then show ?case
    by (simp del: fun_upd_apply add: Let_def convert_fun_upd letpast_sat_alt)
qed (auto split: nat.splits cong: match_cong)

lemma sat_fix_length: "preds \<phi> \<subseteq> A \<Longrightarrow> sat (map_\<Gamma> (fix_length A) \<sigma>) v i \<phi> = sat \<sigma> v i \<phi>"
proof (induct \<phi> arbitrary: \<sigma> v i)
  case (Pred e ts)
  then show ?case
    by (auto split: option.splits)
next
  case (Let p \<phi> \<psi>)
  show ?case
    unfolding sat.simps Let_def using Let(1,3)
    by (subst (1 2) Let(2)[symmetric])
      (auto simp add: Let_def intro!: map_\<Gamma>i_map_\<Gamma>i_cong arg_cong[of _ _ "\<lambda>X. sat X v i \<psi>"] split: if_splits)
next
  case (LetPast p \<phi> \<psi>)
  show ?case
    unfolding sat.simps Let_def using LetPast(3)
    apply (subst (1 2) LetPast(2)[symmetric])
     apply simp
    apply (rule arg_cong[of _ _ "\<lambda>X. sat X v i \<psi>"])
    apply (simp add: o_def)
    apply (rule map_\<Gamma>i_map_\<Gamma>i_cong)
    apply (rule ext)
    apply (simp only: split_beta)
    apply (rule if_cong[OF refl _ refl])
    apply (rule set_eqI)
    apply (simp only: Int_iff conj_commute fun_upd_def)
    apply (rule conj_cong[OF refl])
    apply (unfold if_split_mem2)
    apply (rule conj_cong)
     apply (rule imp_cong[OF refl])
     apply (rule arg_cong2[where f="(\<in>)", OF refl])
     apply (rule subst_letpast_sat)
     apply (rule Collect_cong)
     apply (subst (1 2) LetPast(1)[symmetric])
      apply simp
     apply (rule conj_cong[OF refl])
     apply (rule arg_cong[where f="\<lambda>X. sat X _ _ \<phi>"])
     apply (auto simp: fun_eq_iff intro!: map_\<Gamma>i_map_\<Gamma>i_cong) []
    apply auto
    done
qed (auto simp: subset_eq split: nat.splits cong: match_cong)

lemma sat_unconvert:
  "preds \<phi> \<subseteq> X \<union> A \<Longrightarrow> sat \<sigma> v i \<phi> \<longleftrightarrow> Formula.sat (unconvert X \<sigma>) (unconvertV A \<sigma>) v i \<phi>"
  unfolding sat_convert convert_unconvert by (rule sat_fix_length[symmetric]) simp

lemmas sat_unconvert' = sat_unconvert[where A="{}" and X="preds \<phi>" and \<phi>=\<phi> for \<phi>, simplified]

subsection \<open>Collected correctness results\<close>

definition pprogress :: "'t Formula.formula \<Rightarrow> Sat.prefix \<Rightarrow> nat" where
  "pprogress \<phi> \<pi> = (THE n. \<forall>\<sigma>. prefix_of \<pi> \<sigma> \<longrightarrow> progress (unconvert (preds \<phi>) \<sigma>) Map.empty \<phi> (plen \<pi>) = n)"

lemma pprogress_eq: "prefix_of \<pi> \<sigma> \<Longrightarrow> pprogress \<phi> \<pi> = progress (unconvert (preds \<phi>) \<sigma>) Map.empty \<phi> (plen \<pi>)"
  unfolding pprogress_def plen_punconvert[where A="preds \<phi>", symmetric]
  using progress_prefix_conv prefix_of_unconvert by blast

lemma wty_trace_restrict: "(\<And>i. f (\<Gamma> \<sigma> i) \<subseteq> (\<Gamma> \<sigma> i)) \<Longrightarrow> wty_trace SIG \<sigma> \<Longrightarrow> wty_trace SIG (map_\<Gamma> f \<sigma>)"
  unfolding wty_envs_def by force

sublocale future_bounded_mfodl \<subseteq> Sat: timed_progress "Formula.nfv \<phi>" "Formula.fv \<phi>" "{\<sigma>. unconvert (preds \<phi>) \<sigma> \<in> traces}"
  "\<lambda>\<sigma> v i. sat \<sigma> v i \<phi>" "pprogress \<phi>"
proof (unfold_locales, goal_cases)
  case (1 x)
  then show ?case by (simp add: fvi_less_nfv)
next
  case (2 v v' \<sigma> i)
  then show ?case
    unfolding sat_unconvert' by (auto intro!: sat_fv_cong)
next
  case (3 \<pi>' \<pi>)
  moreover obtain \<sigma> where "prefix_of \<pi>' \<sigma>"
    using ex_prefix_of ..
  moreover have "prefix_of \<pi> \<sigma>"
    using prefix_of_antimono[OF \<open>\<pi> \<le> \<pi>'\<close> \<open>prefix_of \<pi>' \<sigma>\<close>] .
  ultimately show ?case
    by (simp add: pprogress_eq plen_mono Monitor.progress_mono)
next
  case (4 \<sigma> x)
  obtain j where "x \<le> progress (unconvert (preds \<phi>) \<sigma>) Map.empty \<phi> j"
    using future_bounded progress_ge by blast
  then have "x \<le> pprogress \<phi> (take_prefix j \<sigma>)"
    by (simp add: pprogress_eq[of _ \<sigma>])
  then show ?case by force
next
  case (5 \<sigma> \<pi> \<sigma>' i v)
  then have "i < progress (unconvert (preds \<phi>) \<sigma>) Map.empty \<phi> (plen \<pi>)"
    by (simp add: pprogress_eq)
  with 5 show ?case
    unfolding sat_unconvert' unconvertV_empty
    by (intro sat_prefix_conv) (auto elim!: prefix_of_unconvert)
next
  case (6 \<pi> \<pi>')
  from 6(3) have "plen \<pi> = plen \<pi>'"
    by transfer (simp add: list_eq_iff_nth_eq)
  moreover obtain \<sigma> \<sigma>' where "prefix_of \<pi> \<sigma>" "prefix_of \<pi>' \<sigma>'"
    using ex_prefix_of by blast+
  moreover have "\<forall>i < plen \<pi>. \<tau> \<sigma> i = \<tau> \<sigma>' i"
    using 6(3) calculation
    by transfer (simp add: list_eq_iff_nth_eq)
  ultimately show ?case
    by (simp add: pprogress_eq Monitor.progress_time_conv[where j="plen (punconvert (preds \<phi>) _)", simplified])
qed

context verimon
begin

lemma pprogress_punconvert: "Sat.pprogress \<phi> \<pi> = Monitor.pprogress \<phi> (punconvert (preds \<phi>) \<pi>)"
  by (metis Monitor.pprogress_eq Sat.pprogress_eq ex_prefix_of plen_punconvert prefix_of_unconvert)

lemma unconvert_in_traces: "(\<And>i pn. pn \<in> A \<Longrightarrow> \<forall>v \<in> \<Gamma> \<sigma> i pn. length v = snd pn \<longrightarrow> wty_event SIG (fst pn) v) \<Longrightarrow> unconvert A \<sigma> \<in> traces"
  unfolding convert_def unconvert_def traces_def wty_envs_def by auto

lemma M_alt: "Sat.M \<pi> = M (punconvert (preds \<phi>) \<pi>)"
  unfolding Sat.M_def M_def
  unfolding pprogress_punconvert sat_unconvert'
  apply (auto simp: prefix_of_unconvert)
  apply (use ex_prefix_of'[of \<pi>] in \<open>rule exE\<close>)
  subgoal for i v \<sigma> \<tau>
    apply (subgoal_tac "\<forall>i. i < plen \<pi> \<longrightarrow> \<Gamma> (unconvert (preds \<phi>) \<tau>) i = \<Gamma> \<sigma> i")
     prefer 2
    apply (erule thin_rl)
    apply (erule thin_rl)
    apply (erule thin_rl)
     apply (erule thin_rl)
     apply (drule conjunct1)
     apply (unfold unconvert_def punconvert_def) []
     apply transfer
    apply (auto simp: list_eq_iff_nth_eq split: prod.splits) []
  apply (drule spec)
  apply (drule mp)
  apply (rule unconvert_in_traces)
  prefer 2
   apply (drule mp)
    apply (erule conjunct1)
   apply (erule progress_sat_cong[THEN iffD1, rotated -1])
         apply (auto simp: prefix_of_unconvert traces_def wty_envs_def)
    subgoal for k p n
      apply (cases "k < plen \<pi>")
       apply (auto simp: not_less)
      apply (auto simp: unconvert_def)
      done
    subgoal for k p n
      apply (cases "k < plen \<pi>")
       apply (auto simp: not_less)
      apply (auto simp: unconvert_def)
      apply (drule spec, drule mp, assumption)
      apply (drule spec)
      apply (drule bspec)
       apply (erule set_mp[OF equalityD1])
      apply (rule UN_I)
        apply assumption
       apply (unfold prod.case)
       apply (rule imageI)
      apply auto
      done
    done
  done

lemma Mt_alt: "Sat.Mt \<pi> = Mt (punconvert (preds \<phi>) \<pi>)"
  unfolding Sat.Mt_def Mt_def M_alt by simp

lemma last_ts_punconvert[simp]: "last_ts (punconvert A \<pi>) = last_ts \<pi>"
  unfolding punconvert_def by transfer (auto simp: last_map split: list.splits prod.splits)

lemma punconvert_pnil[simp]: "punconvert A pnil = pnil"
  unfolding punconvert_def
  by transfer auto

lemma punconvert_psnoc[simp]: "punconvert A (psnoc \<pi> tdb) = psnoc (punconvert A \<pi>) (apfst (to_db A) tdb)"
  unfolding punconvert_def
  by transfer (auto simp: last_map split: list.splits prod.splits)

definition monitor_invar where "monitor_invar \<equiv> \<lambda>S E \<phi> \<pi> R (st, P). wf_mstate S E \<phi> (punconvert P \<pi>) R st \<and> P = preds \<phi>"
definition monitor_init where "monitor_init \<equiv> \<lambda>\<phi>. (minit_safe \<phi>, preds \<phi>)"
definition monitor_step where "monitor_step \<equiv> \<lambda>db t (st, P). apsnd (\<lambda>st. (st, P)) (mstep (apfst mk_db (to_db P db, t)) st)"

text \<open>Main Results\<close>

lemmas monitor_specification =
  Sat.mono_monitor
  Sat.sound_monitor
  Sat.complete_monitor

theorem invar_minit_safe:
  "S, E \<turnstile> \<phi> \<Longrightarrow> mmonitorable \<phi> \<Longrightarrow> monitor_invar S E \<phi> pnil R (monitor_init \<phi>)"
  by (auto elim: wf_mstate_minit_safe simp: monitor_invar_def monitor_init_def)

theorem invar_mstep:
  assumes "monitor_invar S E \<phi> \<pi> R st" "last_ts \<pi> \<le> t" "wty_db S (fst (to_db (snd st) db, t))"
  shows "monitor_invar S E \<phi> (psnoc \<pi> (db, t)) R (snd (monitor_step db t st))"
  using assms wf_mstate_mstep[of S E \<phi> "punconvert (snd st) \<pi>" R "fst st" "(to_db (snd st) db, t)"]
  by (auto simp: monitor_invar_def monitor_step_def)

theorem mstep_mverdicts:
  assumes "monitor_invar SIG ENV \<phi> \<pi> R st" "last_ts \<pi> \<le> t" "wty_db SIG (fst (to_db (snd st) db, t))" "mem_restr R v"
  shows "((i, t, v) \<in> flatten_verdicts (fst (monitor_step db t st))) =
         ((i, t, v) \<in> Sat.Mt (psnoc \<pi> (db, t)) - Sat.Mt \<pi>)"
  using assms mstep_mverdicts[of "punconvert (snd st) \<pi>" R "fst st" "(to_db (snd st) db, t)"]
  by (auto simp: Mt_alt monitor_invar_def monitor_step_def wf_mstate_def)

end

context maux begin

definition wf_envs where "wf_envs S \<sigma> j \<delta> P P' db =
  (Mapping.keys db \<supseteq> dom P \<union> (\<Union>k \<in> {j ..< j + \<delta>}. {(p, n). \<exists>x. x \<in> \<Gamma> \<sigma> k (p, n) \<and> n = length x}) \<and>
   rel_mapping (\<le>) P P' \<and>
   pred_mapping (\<lambda>i. i \<le> j) P \<and>
   pred_mapping (\<lambda>i. i \<le> j + \<delta>) P' \<and>
   (\<forall>pn \<in> Mapping.keys db. the (Mapping.lookup db pn) = map (\<lambda>k. map Some ` {ts. ts \<in> \<Gamma> \<sigma> k pn \<and> length ts = snd pn})
     (if pn \<in> dom P then [the (P pn)..<the (P' pn)] else [j ..< j + \<delta>])) \<and>
   wty_envs S (unconvert UNIV \<sigma>) (unconvertV (dom P) \<sigma>))"

definition invar_mformula where
  "invar_mformula \<sigma> j P n R \<phi> \<phi>' =
     wf_mformula (unconvert UNIV \<sigma>) j P (unconvertV (dom P) \<sigma>) n R \<phi> \<phi>'"

lemma progress_unconvert: "progress (unconvert A \<sigma>) P \<phi> j = progress \<sigma> P \<phi> j"
  by (simp add: progress_time_conv)

lemma dom_unconvertV[simp]: "dom (unconvertV X \<sigma>) = X"
  by (auto simp: unconvertV_def split: if_splits)

lemma in_\<Gamma>_unconvert[simp]:
  "(p, v) \<in> \<Gamma> (unconvert X \<sigma>) k \<longleftrightarrow> v \<in> \<Gamma> \<sigma> k (p, length v) \<and> (p, length v) \<in> X"
  by (auto simp: unconvert_def)

lemma meval:
  assumes "invar_mformula \<sigma> j P n R \<phi> \<phi>'" "wf_envs S \<sigma> j \<delta> P P' db" "S, E \<turnstile> \<phi>'"
  shows "case meval (j + \<delta>) n (map (\<tau> \<sigma>) [j ..< j + \<delta>]) db \<phi> of (xs, \<phi>\<^sub>n) \<Rightarrow> invar_mformula \<sigma> (j + \<delta>) P' n R \<phi>\<^sub>n \<phi>' \<and>
    list_all2 (\<lambda>i. qtable n (Formula.fv \<phi>') (mem_restr R) (\<lambda>v. Sat.sat \<sigma> (map the v) i \<phi>'))
    [progress \<sigma> P \<phi>' j..<progress \<sigma> P' \<phi>' (j + \<delta>)] xs"
proof -
  from assms have *: "dom P' = dom P"
    unfolding wf_envs_def by (simp add: rel_mapping_alt)
  from assms(1) have "wf_mformula (unconvert UNIV \<sigma>) j P (unconvertV (dom P) \<sigma>) n R \<phi> \<phi>'"
    unfolding invar_mformula_def by simp
  moreover
  from assms(2) have "Monitor.wf_envs S (unconvert UNIV \<sigma>) j \<delta> P P' (unconvertV (dom P) \<sigma>) db"
    unfolding wf_envs_def Monitor.wf_envs_def
    apply clarsimp
    apply safe
    apply blast
    apply force
    apply force
    apply (drule bspec)
     apply (erule set_mp)
    apply blast
    apply (auto simp: list.rel_eq[symmetric] list.rel_map domIff unconvertV_def
        elim!: list.rel_flip[THEN iffD1, OF list.rel_mono_strong])
    done
  ultimately show ?thesis
    using assms(3)
    unfolding invar_mformula_def *
      sat_unconvert[where A = "dom P" and X = UNIV, simplified]
    by (subst (1 2) progress_unconvert[symmetric, where A = UNIV])
      (rule meval[of "(unconvert UNIV \<sigma>)", unfolded \<tau>_unconvert])
qed

corollary meval_Map_empty:
  assumes "invar_mformula \<sigma> j Map.empty n R \<phi> \<phi>'" "wty_trace S (unconvert UNIV \<sigma>)" "S, E \<turnstile> \<phi>'"
    "Mapping.keys db \<supseteq> (\<Union>k \<in> {j ..< j + \<delta>}. {(p, n). \<exists>x. x \<in> \<Gamma> \<sigma> k (p, n) \<and> n = length x})"
    "\<forall>pn \<in> Mapping.keys db. the (Mapping.lookup db pn)
      = map (\<lambda>k. map Some ` {ts. ts \<in> \<Gamma> \<sigma> k pn \<and> length ts = snd pn}) [j ..< j + \<delta>]"
  shows "case meval (j + \<delta>) n (map (\<tau> \<sigma>) [j ..< j + \<delta>]) db \<phi> of (xs, \<phi>\<^sub>n) \<Rightarrow> invar_mformula \<sigma> (j + \<delta>) Map.empty n R \<phi>\<^sub>n \<phi>' \<and>
    list_all2 (\<lambda>i. qtable n (Formula.fv \<phi>') (mem_restr R) (\<lambda>v. Sat.sat \<sigma> (map the v) i \<phi>'))
    [progress \<sigma> Map.empty \<phi>' j..<progress \<sigma> Map.empty \<phi>' (j + \<delta>)] xs"
  using assms by (intro meval) (auto simp add: wf_envs_def rel_mapping_reflp reflp_def)

lemma progress_convert_cong:
  "convert \<sigma> V = convert \<sigma>' V' \<Longrightarrow> progress \<sigma> P \<phi> j = progress \<sigma>' P \<phi> j"
  by (auto simp add: progress_time_conv dest!: arg_cong[where f=\<tau>])

lemma progress_regex_convert_cong:
  "convert \<sigma> V = convert \<sigma>' V' \<Longrightarrow> progress_regex \<sigma> P r j = progress_regex \<sigma>' P r j"
  by (metis progress_convert_cong progress_simps(17))

lemma sat_convert_cong:
  "convert \<sigma> V = convert \<sigma>' V' \<Longrightarrow> Formula.sat \<sigma> V v i \<phi> = Formula.sat \<sigma>' V' v i \<phi>"
  by (simp add: sat_convert)

lemma wf_mformula_convert_cong_aux:
  "wf_mformula \<sigma> j P V m R \<phi> \<phi>' \<Longrightarrow> convert \<sigma> V = convert \<sigma>' V' \<Longrightarrow> wf_mformula \<sigma>' j P V' m R \<phi> \<phi>'"
proof (induction arbitrary: V' rule: wf_mformula.induct)
  case (Let P V m \<phi> \<phi>' p n R \<psi> \<psi>' b)
  show ?case
    apply (rule wf_mformula.Let)
        apply (rule Let.IH(1); fact)
       apply (rule Let.IH(2)[unfolded progress_convert_cong[OF Let.prems]])
       apply (simp add: convert_fun_upd Let.prems del: fun_upd_apply cong: sat_convert_cong)
    by fact+
next
  case (LetPast P p m i V \<phi>' \<phi> n R \<psi> \<psi>' buf b)
  show ?case
    apply (rule wf_mformula.LetPast)
          apply (rule LetPast.IH(1))
    subgoal 1
      apply (simp add: convert_fun_upd LetPast.prems del: fun_upd_apply)
      apply (rule arg_cong[where f="\<lambda>g. map_\<Gamma>i (\<lambda>i db. db(_ := g i)) _"])
      apply (intro ext Collect_cong)
      apply (rule arg_cong[where f="\<lambda>g. Formula.letpast_sat g _ _ \<and> _"])
      apply (simp add: fun_eq_iff LetPast.prems sat_convert_cong[of \<sigma> _ \<sigma>'] convert_fun_upd del: fun_upd_apply)
      done
         apply (simp only: letpast_progress_def)
         apply (rule LetPast.IH(2)[unfolded letpast_progress_def progress_convert_cong[OF LetPast.prems]])
         apply (rule 1)
    subgoal
      apply (insert LetPast.hyps(3))
      apply (simp only: letpast_progress_def progress_convert_cong[OF LetPast.prems])
      apply (erule option.case_cong[OF refl refl, THEN iffD1, rotated])
      apply (rule arg_cong[of "\<lambda>a b c. Formula.sat \<sigma> (_ (Some a)) b c _" "\<lambda>a b c. Formula.sat \<sigma>' (_ (Some a)) b c _"])
      apply (simp add: fun_eq_iff LetPast.prems sat_convert_cong[of \<sigma> _ \<sigma>'] convert_fun_upd del: fun_upd_apply)
      done
    by fact+
next
  case (And P V n R \<phi> \<phi>' \<psi> \<psi>' pos \<chi> buf)
  then show ?case
    by (auto simp add: wf_mbuf2'_def progress_convert_cong[of \<sigma> V \<sigma>' V'] cong: sat_convert_cong
        intro!: wf_mformula.intros)
next
  case (Ands P V n R l l_pos l_neg l' buf A_pos A_neg)
  have 1: "progress \<sigma> = progress \<sigma>'"
    "Formula.sat \<sigma> V = Formula.sat \<sigma>' V'"
    by (simp_all add: fun_eq_iff progress_convert_cong[of \<sigma> V \<sigma>' V'] Ands.prems
        sat_convert_cong[of \<sigma> _ \<sigma>'] convert_fun_upd del: fun_upd_apply)
  show ?case
    apply (rule wf_mformula.Ands[where l_pos=l_pos and l_neg=l_neg])
           apply (rule list.rel_mono_strong[OF Ands.IH])
           apply (simp add: Ands.prems)
    using Ands.hyps(1) apply (simp add: wf_mbufn_def 1)
    by fact+
next
  case (Or P V n R \<phi> \<phi>' \<psi> \<psi>' buf)
  then show ?case
    by (auto simp add: wf_mbuf2'_def progress_convert_cong[of \<sigma> V \<sigma>' V'] cong: sat_convert_cong
        intro!: wf_mformula.intros)
next
  case (Prev P V n R \<phi> \<phi>' first buf nts I)
  then show ?case
    by (auto simp add: progress_convert_cong[of \<sigma> V \<sigma>' V'] cong: sat_convert_cong
        intro!: wf_mformula.intros elim!: list.rel_mono_strong dest!: arg_cong[where f=\<tau>])
next
  case (Next P V n R \<phi> \<phi>' first nts I)
  then show ?case
    by (auto simp add: progress_convert_cong[of \<sigma> V \<sigma>' V'] cong: sat_convert_cong
        intro!: wf_mformula.intros elim!: list.rel_mono_strong dest!: arg_cong[where f=\<tau>])
next
  case (Since P V n R \<phi> \<phi>' \<psi> \<psi>' args \<phi>'' I R' buf aux)
  then have mr: "mem_restr (lift_envs' (length (agg_tys args)) R') = mem_restr R" by auto
  obtain buf\<phi> buf\<psi> ts skew where "buf = (buf\<phi>, buf\<psi>, ts, skew)"
    by (cases buf)
  moreover have "Formula.sat \<sigma> V v i \<phi>' = Formula.sat \<sigma>' V' v i \<phi>'"
    "Formula.sat \<sigma> V v i \<psi>' = Formula.sat \<sigma>' V' v i \<psi>'" for v i
    by (simp_all add: fun_eq_iff Since.prems sat_convert_cong[of \<sigma> _ \<sigma>'] convert_fun_upd del: fun_upd_apply)
  moreover have "\<tau> \<sigma> = \<tau> \<sigma>'"
    by (metis Since.prems \<tau>_convert)
  ultimately show ?case using Since
    apply (intro wf_mformula.Since)
              apply (simp_all add: wf_since_aux_def sat_since_point_def mr
        progress_convert_cong[of \<sigma> V \<sigma>' V'] split del: if_split cong: if_cong) (* SLOW 20s *)
    apply (smt (z3)) by blast
next
  case (Until P V n R \<phi> \<phi>' \<psi> \<psi>' args \<phi>'' I R' buf nts t aux)
  then have mr: "mem_restr (lift_envs' (length (agg_tys args)) R') = mem_restr R" by auto
  have "Formula.sat \<sigma> V v i \<phi>' = Formula.sat \<sigma>' V' v i \<phi>'"
    "Formula.sat \<sigma> V v i \<psi>' = Formula.sat \<sigma>' V' v i \<psi>'" for v i
    by (simp_all add: fun_eq_iff Until.prems sat_convert_cong[of \<sigma> _ \<sigma>'] convert_fun_upd del: fun_upd_apply)
  moreover have "\<tau> \<sigma> = \<tau> \<sigma>'"
    by (metis Until.prems \<tau>_convert)
  ultimately show ?case using Until
    apply (intro wf_mformula.Until)
    apply (simp_all add: mr wf_mbuf2'_def wf_until_aux_def wf_until_auxlist_def wf_ts_def
        progress_convert_cong[of \<sigma> V \<sigma>' V'] split del: if_split cong: if_cong) (* SLOW 30s *)
    by presburger
next
  case (MatchP r P V n R \<phi>s mr mrs buf nts I aux)
  moreover have "Formula.sat \<sigma> V v i \<phi> = Formula.sat \<sigma>' V' v i \<phi>" for v i \<phi>
    by (simp_all add: MatchP.prems sat_convert_cong[of \<sigma> _ \<sigma>'])
  moreover have "\<tau> \<sigma> = \<tau> \<sigma>'"
    by (metis MatchP.prems \<tau>_convert)
  ultimately show ?case
    by (intro wf_mformula.MatchP)
      (auto simp add: wf_mbufn'_def wf_mbufn_def list_all3_map wf_ts_regex_def wf_matchP_aux_def
            progress_convert_cong[of \<sigma> V \<sigma>' V'] progress_regex_convert_cong[of \<sigma> V \<sigma>' V']
            elim!: list.rel_mono_strong list_all3_mono_strong cong: match_cong)
next
  case (MatchF r P V n R \<phi>s mr mrs buf nts t I aux)
  moreover have "Formula.sat \<sigma> V v i \<phi> = Formula.sat \<sigma>' V' v i \<phi>" for v i \<phi>
    by (simp_all add: MatchF.prems sat_convert_cong[of \<sigma> _ \<sigma>'])
  moreover have "\<tau> \<sigma> = \<tau> \<sigma>'"
    by (metis MatchF.prems \<tau>_convert)
  ultimately show ?case
    by (intro wf_mformula.MatchF)
      (auto simp add: wf_mbufn'_def wf_mbufn_def list_all3_map wf_ts_regex_def wf_matchF_aux_def
            progress_convert_cong[of \<sigma> V \<sigma>' V'] progress_regex_convert_cong[of \<sigma> V \<sigma>' V']
            elim!: list.rel_mono_strong list_all3_mono_strong cong: match_cong)
qed (auto intro!: wf_mformula.intros)

lemma convert_unconvert_shadow: "convert (unconvert UNIV \<sigma>) ((unconvertV A \<sigma>)(pn \<mapsto> R))
  = convert (unconvert UNIV (\<sigma>(pn \<Rrightarrow> \<lambda>j. {w. R w j \<and> length w = snd pn})))
    (unconvertV (insert pn A) (\<sigma>(pn \<Rrightarrow> \<lambda>j. {w. R w j \<and> length w = snd pn})))"
  unfolding convert_def unconvert_def unconvertV_def
  apply simp
  apply (rule arg_cong[where f="\<lambda>g. map_\<Gamma>i g \<sigma>"])
  by (auto simp add: fun_eq_iff \<Gamma>_map_\<Gamma>i split: option.split)

lemma sat_unconvert_shadow: "Formula.sat (unconvert UNIV \<sigma>) ((unconvertV A \<sigma>)(pn \<mapsto> R)) v i \<phi>
  = Formula.sat (unconvert UNIV (\<sigma>(pn \<Rrightarrow> \<lambda>j. {w. R w j \<and> length w = snd pn})))
    (unconvertV (insert pn A) (\<sigma>(pn \<Rrightarrow> \<lambda>j. {w. R w j \<and> length w = snd pn}))) v i \<phi>"
  by (intro sat_convert_cong convert_unconvert_shadow)

lemma invar_mformula_Let:
  "invar_mformula \<sigma> j P m UNIV \<phi> \<phi>' \<Longrightarrow>
   invar_mformula (\<sigma>((p, m) \<Rrightarrow> \<lambda>j. {w. Sat.sat \<sigma> w j \<phi>' \<and> length w = m})) j (P((p, m) \<mapsto> Monitor.progress \<sigma> P \<phi>' j)) n
   R \<psi> \<psi>' \<Longrightarrow> {0..<m} \<subseteq> fv \<phi>' \<Longrightarrow> m = Formula.nfv \<phi>' \<Longrightarrow>
   safe_formula \<phi>' \<Longrightarrow> safe_formula \<psi>' \<Longrightarrow>
   invar_mformula \<sigma> j P n R (MLet p m \<phi> \<psi>) (formula.Let p \<phi>' \<psi>')"
  unfolding invar_mformula_def
  apply (rule wf_mformula.Let; assumption?)
  apply (simp add: progress_unconvert)
  apply (erule wf_mformula_convert_cong_aux)
  apply (simp add: convert_unconvert_shadow flip: sat_unconvert)
  done

lemma invar_mformula_LetPast:
  "invar_mformula (\<sigma>((p, m) \<Rrightarrow> letpast_sat (\<lambda>R j. {w. Sat.sat (\<sigma>((p, m) \<Rrightarrow> R)) w j \<phi>' \<and> length w = m}))) j
     (P((p, m) \<mapsto> i)) m UNIV \<phi> \<phi>' \<Longrightarrow>
   invar_mformula (\<sigma>((p, m) \<Rrightarrow> letpast_sat (\<lambda>R j. {w. Sat.sat (\<sigma>((p, m) \<Rrightarrow> R)) w j \<phi>' \<and> length w = m}))) j
     (P((p, m) \<mapsto> letpast_progress \<sigma> P (p, m) \<phi>' j)) n R \<psi> \<psi>' \<Longrightarrow>
   (case buf of
      None \<Rightarrow> i = letpast_progress \<sigma> P (p, m) \<phi>' j
    | Some Z \<Rightarrow> Suc i = letpast_progress \<sigma> P (p, m) \<phi>' j \<and>
        qtable m (Formula.fv \<phi>') (mem_restr UNIV) (\<lambda>v. map the v \<in>
          letpast_sat (\<lambda>R j. {w. Sat.sat (\<sigma>((p, m) \<Rrightarrow> R)) w j \<phi>' \<and> length w = m}) i) Z) \<Longrightarrow>
   safe_letpast (p, m) \<phi>' \<le> PastRec \<Longrightarrow>
   {0..<m} \<subseteq> Formula.fv \<phi>' \<Longrightarrow> m = Formula.nfv \<phi>' \<Longrightarrow>
   safe_formula \<phi>' \<Longrightarrow> safe_formula \<psi>' \<Longrightarrow>
   invar_mformula \<sigma> j P n R (MLetPast p m \<phi> \<psi> i buf) (formula.LetPast p \<phi>' \<psi>')"
  unfolding invar_mformula_def
  apply (rule wf_mformula.LetPast; assumption?)
    apply (simp_all add: letpast_progress_def progress_unconvert cong: option.case_cong)
    apply (erule wf_mformula_convert_cong_aux)
    apply (simp add: convert_unconvert_shadow letpast_sat_alt sat_unconvert_shadow)
    apply (subst sat_unconvert[symmetric], blast)+
    apply simp
   apply (erule wf_mformula_convert_cong_aux)
   apply (simp add: convert_unconvert_shadow letpast_sat_alt sat_unconvert_shadow)
   apply (subst sat_unconvert[symmetric], blast)+
   apply simp
  apply (erule option.case_cong[OF refl refl, THEN iffD1, rotated])
  apply (rule conj_cong[OF refl])
  apply (rule fun_cong[of "qtable _ _ _ _"])
  apply (intro qtable_cong_strong refl)
  apply (simp add: letpast_sat_alt sat_unconvert_shadow del: fun_upd_apply)
  apply (subst sat_unconvert[symmetric], blast)
  apply (simp add: wf_tuple_def)
  done

end

lemma letpast_progress_alt: "pred_mapping (\<lambda>x. x \<le> j) P \<Longrightarrow>
  letpast_progress \<sigma> P p \<phi> j = \<Sqinter>{i. i = progress \<sigma> (P(p \<mapsto> i)) \<phi> j}"
  unfolding letpast_progress_def
  apply (rule antisym)
   apply (rule cInf_greatest)
  apply (blast dest: progress_fixpoint_ex)
  subgoal for x
    apply (cases "x \<le> j")
     apply (blast intro!: cInf_lower)
    apply (drule progress_fixpoint_ex)
   apply clarsimp
    apply (intro cInf_lower2 CollectI conjI)
    apply assumption+
    by auto
  apply (rule cInf_mono)
  apply (blast dest: progress_fixpoint_ex)
    apply simp
  by auto

end


theory Total
imports Determinism "02Stack/StackCorrectness"
begin

theorem correct: "is_value e' \<Longrightarrow> revalue e' = (v, bs) \<Longrightarrow>
    iter (op \<leadsto>) e e' = iter (op \<leadsto>\<^sub>s) (StackState (Eval e) [] empty\<^sub>h) (StackState (Return v) [] h)"
  by simp

end


theory BigStepEvaluate
imports "../Typecheck"
begin

inductive reduce :: "expr \<Rightarrow> expr \<Rightarrow> bool" (infix "\<Down>" 60) where
  red_var [simp]: "Var x \<Down> Var x"
| red_abs [simp]: "Abs t e \<Down> Abs t e"
| red_app [simp]: "e\<^sub>1 \<Down> Abs t e\<^sub>1' \<Longrightarrow> Let e\<^sub>2 e\<^sub>1' \<Down> v \<Longrightarrow> App e\<^sub>1 e\<^sub>2 \<Down> v"
| red_app_let [simp]: "e\<^sub>1 \<Down> Let e\<^sub>1\<^sub>1 e\<^sub>1\<^sub>2 \<Longrightarrow> Let e\<^sub>1\<^sub>1 (App e\<^sub>1\<^sub>2 (incr\<^sub>e\<^sub>e 0 e\<^sub>2)) \<Down> v \<Longrightarrow> App e\<^sub>1 e\<^sub>2 \<Down> v"
| red_let_0 [simp]: "head_var e\<^sub>2' = Some 0 \<Longrightarrow> e\<^sub>2 \<Down> e\<^sub>2' \<Longrightarrow> e\<^sub>1 \<Down> e\<^sub>1' \<Longrightarrow>
    Let e\<^sub>1 (subst\<^sub>e\<^sub>e 0 (incr\<^sub>e\<^sub>e 0 e\<^sub>1) e\<^sub>2) \<Down> v \<Longrightarrow> Let e\<^sub>1 e\<^sub>2 \<Down> v"
| red_let_S [simp]: "head_var e\<^sub>2' \<noteq> Some 0 \<Longrightarrow> e\<^sub>2 \<Down> e\<^sub>2' \<Longrightarrow> Let e\<^sub>1 e\<^sub>2 \<Down> Let e\<^sub>1 e\<^sub>2'"
| red_rec [simp]: "Rec xs \<Down> Rec xs"
| red_proj [simp]: "lookup xs l = Some x \<Longrightarrow> e \<Down> Rec xs \<Longrightarrow> Proj e l \<Down> Var x"
| red_proj_let [simp]: "e \<Down> Let e\<^sub>1 e\<^sub>2 \<Longrightarrow> Let e\<^sub>1 (Proj e\<^sub>2 l) \<Down> v \<Longrightarrow> Proj e l \<Down> v"
| red_inj [simp]: "Inj l ts x \<Down> Inj l ts x"
| red_case [simp]: "lookup cs l = Some e' \<Longrightarrow> e \<Down> Inj l ts x \<Longrightarrow> Let (Var x) e' \<Down> v \<Longrightarrow>
    Case e t cs \<Down> v"
| red_case_let [simp]: "e \<Down> Let e\<^sub>1 e\<^sub>2 \<Longrightarrow> Let e\<^sub>1 (Case e\<^sub>2 t (map (incr\<^sub>e\<^sub>e (Suc 0)) cs)) \<Down> v \<Longrightarrow>
    Case e t cs \<Down> v"
| red_fold [simp]: "Fold t x \<Down> Fold t x"
| red_unfold [simp]: "e \<Down> Fold t x \<Longrightarrow> Unfold t e \<Down> Var x"
| red_unfold_let [simp]: "e \<Down> Let e\<^sub>1 e\<^sub>2 \<Longrightarrow> Let e\<^sub>1 (Unfold t e\<^sub>2) \<Down> v \<Longrightarrow> Unfold t e \<Down> v"
| red_tyabs [simp]: "TyAbs k e \<Down> TyAbs k e"
| red_tyapp [simp]: "e \<Down> TyAbs k e' \<Longrightarrow> subst\<^sub>t\<^sub>e 0 t e' \<Down> v \<Longrightarrow> TyApp e t \<Down> v"
| red_tyapp_let [simp]: "e \<Down> Let e\<^sub>1 e\<^sub>2 \<Longrightarrow> Let e\<^sub>1 (TyApp e\<^sub>2 t) \<Down> v \<Longrightarrow> TyApp e t \<Down> v"
| red_tylet [simp]: "subst\<^sub>t\<^sub>e 0 t e \<Down> v \<Longrightarrow> TyLet t e \<Down> v"

theorem preservation [elim]: "e \<Down> v \<Longrightarrow> \<Delta>,\<Gamma> \<turnstile> e : t \<Longrightarrow> \<Delta>,\<Gamma> \<turnstile> v : t"
  proof (induction e v arbitrary: \<Gamma> t rule: reduce.induct)
  case (red_proj xs l x e)
    hence "lookup \<Gamma> x = Some t" by fastforce
    thus ?case by simp
  next case (red_case cs l e' e ts x v tt)
    moreover hence "(\<Delta>,\<Gamma> \<turnstile> e : Variant ts) \<and> (\<Delta>,\<Gamma> \<turnstile>\<^sub>c cs : ts \<rightarrow> t) \<and> (\<Delta> \<turnstile>\<^sub>k t : Star)" by fastforce
    moreover with red_case obtain t' where T: "lookup \<Gamma> x = Some t' \<and> lookup ts l = Some t' \<and>
      (\<forall>tt \<in> set ts. \<Delta> \<turnstile>\<^sub>k tt : Star)" by blast
    ultimately have "\<Delta>,insert_at 0 t' \<Gamma> \<turnstile> e' : t" by auto
    with red_case T show ?case by (metis tc_let tc_var)
  next case (red_tyapp e k e' tt v)
    then obtain t' k' where T: "t = subst\<^sub>t\<^sub>t 0 tt t' \<and> (\<Delta>,\<Gamma> \<turnstile> e : Forall k' t') \<and> (\<Delta> \<turnstile>\<^sub>k tt : k')"
      by fastforce
    with red_tyapp have "insert_at 0 k' \<Delta>,map (incr\<^sub>t\<^sub>t 0) \<Gamma> \<turnstile> e' : t'" by fastforce
    with T have "\<Delta>,map (subst\<^sub>t\<^sub>t 0 tt) (map (incr\<^sub>t\<^sub>t 0) \<Gamma>) \<turnstile> subst\<^sub>t\<^sub>e 0 tt e' : subst\<^sub>t\<^sub>t 0 tt t'"
      by (metis tc_subst\<^sub>t\<^sub>e le0)
    with red_tyapp T show ?case by simp
  qed fastforce+

(* we can't actually do progress because the language is not normalizing *)
(* instead we prove the weaker claim that we get a value _if it's defined at all_ *)

lemma reduce_to_value' [simp]: "e \<Down> v \<Longrightarrow> \<Delta>,\<Gamma> \<turnstile> e : t \<Longrightarrow>
      is_value v \<or> (\<exists>x < length \<Gamma>. head_var v = Some x)"
  proof (induction e v arbitrary: \<Gamma> rule: reduce.induct)
  case (red_app e\<^sub>1 tt e\<^sub>1' e\<^sub>2 v)
    then obtain t\<^sub>1 where T: "(\<Delta>,\<Gamma> \<turnstile> e\<^sub>1 : Arrow t\<^sub>1 t) \<and> (\<Delta>,\<Gamma> \<turnstile> e\<^sub>2 : t\<^sub>1)" by fastforce
    with red_app have "\<Delta>,\<Gamma> \<turnstile> Abs tt e\<^sub>1' : Arrow t\<^sub>1 t" by fastforce
    with T have "\<Delta>,\<Gamma> \<turnstile> Let e\<^sub>2 e\<^sub>1' : t" by auto
    with red_app show ?case by simp
  next case (red_app_let e\<^sub>1 e\<^sub>1\<^sub>1 e\<^sub>1\<^sub>2 e\<^sub>2 v)
    then obtain t\<^sub>1 where T: "(\<Delta>,\<Gamma> \<turnstile> e\<^sub>1 : Arrow t\<^sub>1 t) \<and> (\<Delta>,\<Gamma> \<turnstile> e\<^sub>2 : t\<^sub>1)" by fastforce
    with red_app_let have "\<Delta>,\<Gamma> \<turnstile> Let e\<^sub>1\<^sub>1 e\<^sub>1\<^sub>2 : Arrow t\<^sub>1 t" by fastforce
    then obtain tt where "(\<Delta>,\<Gamma> \<turnstile> e\<^sub>1\<^sub>1 : tt) \<and> (\<Delta>,insert_at 0 tt \<Gamma> \<turnstile> e\<^sub>1\<^sub>2 : Arrow t\<^sub>1 t)" by fastforce
    with T have "\<Delta>,\<Gamma> \<turnstile> Let e\<^sub>1\<^sub>1 (App e\<^sub>1\<^sub>2 (incr\<^sub>e\<^sub>e 0 e\<^sub>2)) : t" by fastforce
    with red_app_let show ?case by simp
  next case (red_let_0 e\<^sub>2' e\<^sub>2 e\<^sub>1 e\<^sub>1' v)
    hence "\<Delta>,\<Gamma> \<turnstile> Let e\<^sub>1 (subst\<^sub>e\<^sub>e 0 (incr\<^sub>e\<^sub>e 0 e\<^sub>1) e\<^sub>2) : t" by fastforce
    with red_let_0 show ?case by simp
  next case (red_let_S e\<^sub>2' e\<^sub>2 e\<^sub>1)
    from red_let_S have "\<Delta>,\<Gamma> \<turnstile> Let e\<^sub>1 e\<^sub>2 : t" by simp
    then obtain t\<^sub>1 where "(\<Delta>,\<Gamma> \<turnstile> e\<^sub>1 : t\<^sub>1) \<and> (\<Delta>,insert_at 0 t\<^sub>1 \<Gamma> \<turnstile> e\<^sub>2 : t)" by fastforce
    with red_let_S have "is_value e\<^sub>2' \<or> (\<exists>x < length (insert_at 0 t\<^sub>1 \<Gamma>). head_var e\<^sub>2' = Some x)"
      by blast
    with red_let_S show ?case by (auto split: nat.splits)
  next case (red_proj xs l x e)
    then obtain ts where "(\<Delta>,\<Gamma> \<turnstile> e : Record ts) \<and> lookup ts l = Some t" by fastforce
    with red_proj have "\<Delta>,\<Gamma> \<turnstile> Rec xs : Record ts" by fastforce
    with red_proj show ?case by auto
  next case (red_proj_let e e\<^sub>1 e\<^sub>2 l v)
    then obtain ts where T: "(\<Delta>,\<Gamma> \<turnstile> e : Record ts) \<and> lookup ts l = Some t" by fastforce
    with red_proj_let have "\<Delta>,\<Gamma> \<turnstile> Let e\<^sub>1 e\<^sub>2 : Record ts" by fastforce
    then obtain t\<^sub>1 where "(\<Delta>,\<Gamma> \<turnstile> e\<^sub>1 : t\<^sub>1) \<and> (\<Delta>,insert_at 0 t\<^sub>1 \<Gamma> \<turnstile> e\<^sub>2 : Record ts)" by fastforce
    with T have "\<Delta>,\<Gamma> \<turnstile> Let e\<^sub>1 (Proj e\<^sub>2 l) : t" by fastforce
    with red_proj_let show ?case by simp
  next case (red_case cs l e' e ts x v tt)
    then obtain ts' where T: "tt = t \<and> (\<Delta>,\<Gamma> \<turnstile> e : Variant ts') \<and> (\<Delta>,\<Gamma> \<turnstile>\<^sub>c cs : ts' \<rightarrow> t) \<and>
      (\<Delta> \<turnstile>\<^sub>k t : Star)" by fastforce
    with red_case have "\<Delta>,\<Gamma> \<turnstile> Inj l ts x : Variant ts'" by fastforce
    then obtain t' where S: "ts' = ts \<and> lookup \<Gamma> x = Some t' \<and> lookup ts l = Some t' \<and>
      (\<forall>tt \<in> set ts. \<Delta> \<turnstile>\<^sub>k tt : Star)" by fastforce
    with red_case T have X: "\<Delta>,insert_at 0 t' \<Gamma> \<turnstile> e' : t" by auto
    from S have "\<Delta>,\<Gamma> \<turnstile> Var x : t'" by simp
    with X have "\<Delta>,\<Gamma> \<turnstile> Let (Var x) e' : t" by simp
    with red_case T show ?case by simp
  next case (red_case_let e e\<^sub>1 e\<^sub>2 tt cs v)
    then obtain ts where T: "t = tt \<and> (\<Delta>,\<Gamma> \<turnstile> e : Variant ts) \<and> (\<Delta>,\<Gamma> \<turnstile>\<^sub>c cs : ts \<rightarrow> t) \<and>
      (\<Delta> \<turnstile>\<^sub>k t : Star)" by fastforce
    with red_case_let have "\<Delta>,\<Gamma> \<turnstile> Let e\<^sub>1 e\<^sub>2 : Variant ts" by fastforce
    then obtain t\<^sub>1 where "(\<Delta>,\<Gamma> \<turnstile> e\<^sub>1 : t\<^sub>1) \<and> (\<Delta>,insert_at 0 t\<^sub>1 \<Gamma> \<turnstile> e\<^sub>2 : Variant ts)" by fastforce
    with T have "\<Delta>,\<Gamma> \<turnstile> Let e\<^sub>1 (Case e\<^sub>2 tt (map (incr\<^sub>e\<^sub>e (Suc 0)) cs)) : t" by fastforce
    with red_case_let show ?case by simp
  next case (red_unfold e tt x)
    then obtain k where T: "t = subst\<^sub>t\<^sub>t 0 (Inductive k tt) tt \<and> (\<Delta>,\<Gamma> \<turnstile> e : Inductive k tt) \<and>
      (insert_at 0 k \<Delta> \<turnstile>\<^sub>k tt : Star)" by fastforce
    with red_unfold have "\<Delta>,\<Gamma> \<turnstile> Fold tt x : Inductive k tt" by fastforce
    hence "lookup \<Gamma> x = Some (subst\<^sub>t\<^sub>t 0 (Inductive k tt) tt) \<and> (insert_at 0 k \<Delta> \<turnstile>\<^sub>k tt : Star)"
      by fastforce
    with T show ?case by auto
  next case (red_unfold_let e e\<^sub>1 e\<^sub>2 tt v)
    then obtain k where T: "t = subst\<^sub>t\<^sub>t 0 (Inductive k tt) tt \<and> (\<Delta>,\<Gamma> \<turnstile> e : Inductive k tt) \<and>
      (insert_at 0 k \<Delta> \<turnstile>\<^sub>k tt : Star)" by fastforce
    with red_unfold_let have "\<Delta>,\<Gamma> \<turnstile> Let e\<^sub>1 e\<^sub>2 : Inductive k tt" by fastforce
    then obtain t\<^sub>1 where "(\<Delta>,\<Gamma> \<turnstile> e\<^sub>1 : t\<^sub>1) \<and> (\<Delta>,insert_at 0 t\<^sub>1 \<Gamma> \<turnstile> e\<^sub>2 : Inductive k tt)"
      by fastforce
    with T have "\<Delta>,\<Gamma> \<turnstile> Let e\<^sub>1 (Unfold tt e\<^sub>2) : t" by fastforce
    with red_unfold_let show ?case by simp
  next case (red_tyapp e k e' t' v)
    then obtain tt kk where T: "t = subst\<^sub>t\<^sub>t 0 t' tt \<and> (\<Delta>,\<Gamma> \<turnstile> e : Forall kk tt) \<and> (\<Delta> \<turnstile>\<^sub>k t' : kk)"
      by fastforce
    with red_tyapp have "\<Delta>,\<Gamma> \<turnstile> TyAbs k e' : Forall kk tt" by fastforce
    hence "kk = k \<and> insert_at 0 k \<Delta>,map (incr\<^sub>t\<^sub>t 0) \<Gamma> \<turnstile> e' : tt" by fastforce
    with T have "\<Delta>,map (subst\<^sub>t\<^sub>t 0 t') (map (incr\<^sub>t\<^sub>t 0) \<Gamma>) \<turnstile> subst\<^sub>t\<^sub>e 0 t' e' : subst\<^sub>t\<^sub>t 0 t' tt"
      by (metis tc_subst\<^sub>t\<^sub>e le0)
    with red_tyapp T show ?case by simp
  next case (red_tyapp_let e e\<^sub>1 e\<^sub>2 tt v)
    then obtain t' k where T: "t = subst\<^sub>t\<^sub>t 0 tt t' \<and> (\<Delta>,\<Gamma> \<turnstile> e : Forall k t') \<and> (\<Delta> \<turnstile>\<^sub>k tt : k)"
      by fastforce
    with red_tyapp_let have "\<Delta>,\<Gamma> \<turnstile> Let e\<^sub>1 e\<^sub>2 : Forall k t'" by fastforce
    then obtain t\<^sub>1 where "(\<Delta>,\<Gamma> \<turnstile> e\<^sub>1 : t\<^sub>1) \<and> (\<Delta>,insert_at 0 t\<^sub>1 \<Gamma> \<turnstile> e\<^sub>2 : Forall k t')" by fastforce
    with T have "\<Delta>,\<Gamma> \<turnstile> Let e\<^sub>1 (TyApp e\<^sub>2 tt) : t" by fastforce
    with red_tyapp_let show ?case by simp
  qed auto

theorem reduce_to_value: "e \<Down> v \<Longrightarrow> \<Delta>,[] \<turnstile> e : t \<Longrightarrow> is_value v"
  using reduce_to_value' by fastforce

end


(*  Title:      ZF/Inductive_ZF.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1993  University of Cambridge

Inductive definitions use least fixedpoints with standard products and sums
Coinductive definitions use greatest fixedpoints with Quine products and sums

Sums are used only for mutual recursion;
Products are used only to derive "streamlined" induction rules for relations
*)

section{*Inductive and Coinductive Definitions*}

theory Inductive_ZF
imports Fixedpt QPair Nat_ZF
keywords
  "inductive" "coinductive" "inductive_cases" "rep_datatype" "primrec" :: thy_decl and
  "domains" "intros" "monos" "con_defs" "type_intros" "type_elims"
  "elimination" "induction" "case_eqns" "recursor_eqns"
begin

lemma def_swap_iff: "a == b ==> a = c \<longleftrightarrow> c = b"
  by blast

lemma def_trans: "f == g ==> g(a) = b ==> f(a) = b"
  by simp

lemma refl_thin: "!!P. a = a ==> P ==> P" .

ML_file "ind_syntax.ML"
ML_file "Tools/ind_cases.ML"
ML_file "Tools/cartprod.ML"
ML_file "Tools/inductive_package.ML"
ML_file "Tools/induct_tacs.ML"
ML_file "Tools/primrec_package.ML"

ML {*
structure Lfp =
  struct
  val oper      = @{const lfp}
  val bnd_mono  = @{const bnd_mono}
  val bnd_monoI = @{thm bnd_monoI}
  val subs      = @{thm def_lfp_subset}
  val Tarski    = @{thm def_lfp_unfold}
  val induct    = @{thm def_induct}
  end;

structure Standard_Prod =
  struct
  val sigma     = @{const Sigma}
  val pair      = @{const Pair}
  val split_name = @{const_name split}
  val pair_iff  = @{thm Pair_iff}
  val split_eq  = @{thm split}
  val fsplitI   = @{thm splitI}
  val fsplitD   = @{thm splitD}
  val fsplitE   = @{thm splitE}
  end;

structure Standard_CP = CartProd_Fun (Standard_Prod);

structure Standard_Sum =
  struct
  val sum       = @{const sum}
  val inl       = @{const Inl}
  val inr       = @{const Inr}
  val elim      = @{const case}
  val case_inl  = @{thm case_Inl}
  val case_inr  = @{thm case_Inr}
  val inl_iff   = @{thm Inl_iff}
  val inr_iff   = @{thm Inr_iff}
  val distinct  = @{thm Inl_Inr_iff}
  val distinct' = @{thm Inr_Inl_iff}
  val free_SEs  = Ind_Syntax.mk_free_SEs
            [distinct, distinct', inl_iff, inr_iff, Standard_Prod.pair_iff]
  end;

structure Ind_Package =
    Add_inductive_def_Fun
      (structure Fp=Lfp and Pr=Standard_Prod and CP=Standard_CP
       and Su=Standard_Sum val coind = false);

structure Gfp =
  struct
  val oper      = @{const gfp}
  val bnd_mono  = @{const bnd_mono}
  val bnd_monoI = @{thm bnd_monoI}
  val subs      = @{thm def_gfp_subset}
  val Tarski    = @{thm def_gfp_unfold}
  val induct    = @{thm def_Collect_coinduct}
  end;

structure Quine_Prod =
  struct
  val sigma     = @{const QSigma}
  val pair      = @{const QPair}
  val split_name = @{const_name qsplit}
  val pair_iff  = @{thm QPair_iff}
  val split_eq  = @{thm qsplit}
  val fsplitI   = @{thm qsplitI}
  val fsplitD   = @{thm qsplitD}
  val fsplitE   = @{thm qsplitE}
  end;

structure Quine_CP = CartProd_Fun (Quine_Prod);

structure Quine_Sum =
  struct
  val sum       = @{const qsum}
  val inl       = @{const QInl}
  val inr       = @{const QInr}
  val elim      = @{const qcase}
  val case_inl  = @{thm qcase_QInl}
  val case_inr  = @{thm qcase_QInr}
  val inl_iff   = @{thm QInl_iff}
  val inr_iff   = @{thm QInr_iff}
  val distinct  = @{thm QInl_QInr_iff}
  val distinct' = @{thm QInr_QInl_iff}
  val free_SEs  = Ind_Syntax.mk_free_SEs
            [distinct, distinct', inl_iff, inr_iff, Quine_Prod.pair_iff]
  end;

structure CoInd_Package =
  Add_inductive_def_Fun(structure Fp=Gfp and Pr=Quine_Prod and CP=Quine_CP
    and Su=Quine_Sum val coind = true);

*}

end


theory Term
  imports Main
begin

no_notation
  implies  (infixr "-->" 25)

type_synonym indexname = "String.literal * integer"
type_synonym "class" = String.literal
type_synonym sort = "class list"

datatype "typ" =
  Type  "String.literal" "typ list" |
  TFree "String.literal" "sort" |
  TVar  "indexname" "sort"

definition "dummyT = Type (STR ''dummy'') []"
definition funT :: "typ \<Rightarrow> typ \<Rightarrow> typ" (infixr "-->" 25) where
"funT S T = Type (STR ''fun'') [S,T]"

code_printing
    type_constructor "typ" \<rightharpoonup> (SML) "typ"
  | constant "Type" \<rightharpoonup> (SML) "Term.Type (_, _)"
  | constant "TFree" \<rightharpoonup> (SML) "TFree (_, _)"
  | constant "TVar" \<rightharpoonup> (SML) "TVar (_, _)"
  | constant "dummyT" \<rightharpoonup> (SML) "Term.dummyT"
  | constant "funT" \<rightharpoonup> (SML) "_ --> _"

datatype "term" =
  Const String.literal "typ" |
  Free String.literal "typ" |
  Var indexname "typ" |
  Bound "integer" |
  Abs String.literal "typ" "term" |
  App "term" "term" (infixl "$" 200 )

definition "propT = Type (STR ''prop'') []"

fun aconv :: "term \<Rightarrow> term \<Rightarrow> bool" (infix "aconv" 50) where
  "(t1 $ u1) aconv (t2 $ u2) = (t1 aconv t2 \<and> u1 aconv u2)"
| "Abs _ T1 t1 aconv Abs _ T2 t2 = (t1 aconv t2 \<and> T1 = T2)"
| "a1 aconv a2 = (a1 = a2)"

lemma aconv_refl: "x aconv x"
  by (induct x, simp_all)

fun fastype_of1 :: "typ list \<Rightarrow> term \<Rightarrow> typ" where
"fastype_of1 Ts (f $ u) =
   (case fastype_of1 Ts f of
      Type n (_ # T # []) \<Rightarrow> (if (n = STR ''fun'') then T else undefined) |
      _ \<Rightarrow> undefined)" |
"fastype_of1 _ (Const _ T) = T" |
"fastype_of1 _ (Free _ T) = T" |
"fastype_of1 Ts (Bound i) = Ts ! (nat (int_of_integer i))" |
"fastype_of1 _ (Var _ T) = T" |
"fastype_of1 Ts (Abs _ T u) = funT T (fastype_of1 (T # Ts) u)"

definition [simp]: "fastype_of t = fastype_of1 [] t"

definition "const n = Const n dummyT"

definition "free n = Free n dummyT"

consts lambda :: "term \<Rightarrow> term \<Rightarrow> term"

consts subst_free :: "(term \<times> term) list \<Rightarrow> term \<Rightarrow> term"

subsection \<open> Code Generation Axioms \<close>

code_printing
  type_constructor "term" \<rightharpoonup> (SML) "term"
  | constant "Const" \<rightharpoonup> (SML) "Const (_, _)"
  | constant "Free" \<rightharpoonup> (SML) "Free (_, _)"
  | constant "Var" \<rightharpoonup> (SML) "Var (_, _)"
  | constant "Bound" \<rightharpoonup> (SML) "Bound _"
  | constant "Abs" \<rightharpoonup> (SML) "Abs (_, _, _)"
  | constant "App" \<rightharpoonup> (SML) "_ $ _"
  | constant "propT" \<rightharpoonup> (SML) "propT"
  | constant "fastype_of" \<rightharpoonup> (SML) "Term.fastype'_of"
  | constant "subst_free" \<rightharpoonup> (SML) "Term.subst'_free"
  | constant "lambda" \<rightharpoonup> (SML) "Term.lambda"
  | constant "const" \<rightharpoonup> (SML) "Syntax.const"
  | constant "free" \<rightharpoonup> (SML) "Syntax.free"

end


theory Unique
  imports Main Definitions Exp Star
begin

section \<open>Semantics of Commands\<close>

text \<open>This section describes the small-step semantics of commands.
The configuration of an execution consists of:
\<^item> the tags issued $T$ (of type @{type tags});
\<^item> the heap $H$ (of type @{type heap}) which holds the actual data and the reborrow trees
  for each address; and
\<^item> the command to be executed $c$ (of type @{type com}).
The variable environment $\Gamma$ (of type @{type gamma}) is fixed throughout the execution.
\<close>

type_synonym config = "tags * heap * com"
inductive com_sem :: "gamma \<Rightarrow> config \<Rightarrow> config \<Rightarrow> bool" ("(_ \<turnstile> _ \<rightarrow> _)") for \<Gamma>
where
  Assign: "\<lbrakk>\<Gamma> \<turnstile>\<^sub>w (H, p) \<Down>\<^sub>p (H', Reference a t); writable H' (a, t); H'' = kill_heap (a, t) H';
            \<Gamma> \<turnstile> (T, H'', rv) \<Down> (T', H''', v); H''' ! a = (_, ts)\<rbrakk>
           \<Longrightarrow> \<Gamma> \<turnstile> (T, H, p ::= rv) \<rightarrow> (T', H''[a := (v, ts)], Skip)" |
  SeqL: "\<Gamma> \<turnstile> (T, H, Skip;; c) \<rightarrow> (T, H, c)" |
  SeqR: "\<Gamma> \<turnstile> (T, H, c1) \<rightarrow> (T', H', c') \<Longrightarrow> \<Gamma> \<turnstile> (T, H, c1;; c2) \<rightarrow> (T', H', c';; c2)" |
  IfTrue: "\<Gamma> \<turnstile> (T, H, b) \<Down> (T', H', VBool True)
           \<Longrightarrow> \<Gamma> \<turnstile> (T, H, IF b THEN c1 ELSE c2) \<rightarrow> (T', H', c1)" |
  IfFalse: "\<Gamma> \<turnstile> (T, H, b) \<Down> (T', H', VBool False)
           \<Longrightarrow> \<Gamma> \<turnstile> (T, H, IF b THEN c1 ELSE c2) \<rightarrow> (T', H', c2)" |
  While: "\<Gamma> \<turnstile> (T, H, WHILE b DO c) \<rightarrow> (T, H, IF b THEN (c;; WHILE b DO c) ELSE Skip)"

(*<*)
lemmas com_sem_cases = com_sem.cases[split_format(complete)]
lemmas com_sem_induct = com_sem.induct[split_format(complete)]
declare com_sem.intros[simp, intro]

(* We declare safe elimination rules (automatically applied I guess?) *)
inductive_cases ComE[elim!]:
  "\<Gamma> \<turnstile> (T, H, x ::= e) \<rightarrow> cfg"
  "\<Gamma> \<turnstile> (T, H, Skip;; c) \<rightarrow> cfg"
  "\<Gamma> \<turnstile> (T, H, c1;; c2) \<rightarrow> cfg"
  "\<Gamma> \<turnstile> (T, H, IF b THEN c1 ELSE c2) \<rightarrow> cfg"

(* WHILE might not terminate, so we declare it as an unsafe elimination rule *)
inductive_cases WhileE[elim]: "\<Gamma> \<turnstile> (T, H, WHILE b DO c) \<rightarrow> cfg"
(*>*)

abbreviation com_sem_steps :: "gamma \<Rightarrow> config \<Rightarrow> config \<Rightarrow> bool" ("(_ \<turnstile> _ \<rightarrow>\<^sup>* _)") where
  "\<Gamma> \<turnstile> cfg \<rightarrow>\<^sup>* cfg' == star (com_sem \<Gamma>) cfg cfg'"

text \<open>
Figure \ref{fig:com} shows the assignment rules. Other commands are standard.

The {\sc{Assign}} rule assigns a value to the the location.
First, \<^term>\<open>\<Gamma> \<turnstile>\<^sub>w (H, p) \<Down>\<^sub>p (H', Reference a t)\<close> computes the location with write modifier.
Next, \<^term>\<open>writable H' (a, t)\<close> and \<^term>\<open>H'' = kill_heap (a, t) H'\<close> assert that the reference is
writable and unique. Note that this assertion is made \<^emph>\<open>before\<close> the evaluation of the right hand side.
This means Unique does not support Two Phase Borrows currently.
Finally, we compute the right hand side and assigns the result to the location.

\begin{figure}[h]
\centering
\begin{framed}
@{thm[mode=Rule] Assign} \sc{Assign}
\end{framed}
\caption{The assignment rule}
\label{fig:com}
\end{figure}
\<close>

text \<open>The following lemmas show that the execution of the commands is deterministic.\<close>

definition final :: "config \<Rightarrow> bool" where
  "final cfg \<longleftrightarrow> (case cfg of (_, _, Skip) \<Rightarrow> True | _ \<Rightarrow> False)"

definition stuck :: "gamma \<Rightarrow> config \<Rightarrow> bool" where
  "stuck \<Gamma> cfg \<longleftrightarrow> (case cfg of
     (_, _, Skip) \<Rightarrow> False |
     _ \<Rightarrow> \<not>(\<exists>cfg'. (\<Gamma> \<turnstile> cfg \<rightarrow> cfg')))"

lemma skip_final_noteq[simp]: "\<Gamma> \<turnstile> (T, H, c) \<rightarrow> (T, H', c') \<Longrightarrow> c \<noteq> Skip"
proof (cases rule: com_sem_cases)
qed auto

lemma skip_final[simp]: "\<Gamma> \<turnstile> (T, H, Skip) \<rightarrow> (T', H', c) \<Longrightarrow> False"
proof (cases \<Gamma> "(T, H, Skip)" "(T', H', c)" rule: com_sem_cases)
qed auto

lemma com_sem_det: "\<Gamma> \<turnstile> cfg \<rightarrow> cfg' \<Longrightarrow> \<Gamma> \<turnstile> cfg \<rightarrow> cfg'' \<Longrightarrow> cfg'' = cfg'"
proof (induction arbitrary: cfg'' rule: com_sem.induct)
  case (Assign H p H' a t H'' T rv T' H''' v uu ts)
  show ?case
  proof (rule ComE(1))
    show "\<Gamma> \<turnstile> (T, H, p ::= rv) \<rightarrow> cfg''" using Assign.prems by simp
  next
    fix H'a aa ta T'a H'''a va uua tsa
    let ?killed = "(case H'a ! aa of (v, ts) \<Rightarrow> H'a[aa := (v, kill ta ts)]) :: heap"
    assume "\<Gamma> \<turnstile>\<^sub>w (H, p) \<Down>\<^sub>p (H'a, Reference aa ta)"
    then have "H'a = H' \<and> aa = a \<and> ta = t" using Assign.hyps place_sem_det' by fastforce
    moreover
    have "?killed = H''" using Assign.hyps calculation by simp
    moreover
    assume "\<Gamma> \<turnstile> (T, ?killed, rv) \<Down> (T'a, H'''a, va)"
    then have "\<Gamma> \<turnstile> (T, H'', rv) \<Down> (T'a, H'''a, va)" using calculation by simp
    then have "T'a = T' \<and> H'''a = H''' \<and> va = v" using Assign.hyps(4) rvalue_sem_det by fastforce
    moreover
    assume "H'''a ! aa = (uua, tsa)"
    then have "tsa = ts" by (simp add: Assign.hyps(5) calculation(1) calculation(3))
    moreover
    assume "cfg'' = (T'a, ?killed[aa := (va, tsa)], Skip)"
    thus ?thesis using calculation by simp
  qed
next
  case (SeqL T H c)
  then show ?case by (meson ComE(3) skip_final)
next
case (SeqR T H c1 T' H' c' c2)
  then show ?case by (metis ComE(3) prod.inject skip_final)
next
  case (IfTrue T H b T' H' c1 c2)
  show ?case
  proof (rule ComE(4))
    show "\<Gamma> \<turnstile> (T, H, IF b THEN c1 ELSE c2) \<rightarrow> cfg''" using IfTrue.prems by simp
  next
    fix T'a H'a
    assume "\<Gamma> \<turnstile> (T, H, b) \<Down> (T'a, H'a, VBool True)"
    then have "T'a = T' \<and> H'a = H'" using IfTrue.hyps rvalue_sem_det by simp
    moreover assume "cfg'' = (T'a, H'a, c1)"
    thus ?thesis using calculation by simp
  next
    fix T'a H'a
    assume "\<Gamma> \<turnstile> (T, H, b) \<Down> (T'a, H'a, VBool False)"
    then show ?thesis using IfTrue.hyps rvalue_sem_det by blast
  qed
next
  case (IfFalse T H b T' H' c1 c2)
  show ?case
  proof (rule ComE(4))
    show "\<Gamma> \<turnstile> (T, H, IF b THEN c1 ELSE c2) \<rightarrow> cfg''" using IfFalse.prems by simp
  next
    fix T'a H'a
    assume "\<Gamma> \<turnstile> (T, H, b) \<Down> (T'a, H'a, VBool False)"
    then have "T'a = T' \<and> H'a = H'" using IfFalse.hyps rvalue_sem_det by simp
    moreover assume "cfg'' = (T'a, H'a, c2)"
    thus ?thesis using calculation by simp
  next
    fix T'a H'a
    assume "\<Gamma> \<turnstile> (T, H, b) \<Down> (T'a, H'a, VBool True)"
    then show ?thesis using IfFalse.hyps rvalue_sem_det by blast
  qed
next
  case (While T H b c)
then show ?case by auto
qed
lemmas star_induct' = star.induct[of "com_sem \<Gamma>", split_format(complete)] \<^marker>\<open>tag invisible\<close>

text \<open>We show the transitivity of @{const com_sem_steps}.\<close>

lemma com_seql_trans:
  "\<Gamma> \<turnstile> (T, H, c1) \<rightarrow>\<^sup>* (T', H', c1') \<Longrightarrow> \<Gamma> \<turnstile> (T, H, c1;; c2) \<rightarrow>\<^sup>* (T', H', c1';; c2)"
proof (induction rule: star_induct')
  case (refl a a b)
  then show ?case by simp
next
  case (step a a b a a b a a b)
  then show ?case by (meson SeqR star.simps)
qed

section \<open>Code examples\<close>

text \<open>We need to assign a pre-allocated location to each variable to run a program.
Currently we initialize those locations with zeros, but they will be uninitialized when we implement
uninitialized slots.\<close>

abbreviation "\<Gamma>\<^sub>0 == \<lambda>_. undefined"
fun preallocate' :: "vname list \<Rightarrow> gamma * tags * heap \<Rightarrow> gamma * tags * heap" where
  "preallocate' [] ret = ret" |
  "preallocate' (x # xs) (\<Gamma>, T, H) =
    (let t = length T in
     let \<Gamma>' = \<Gamma>(x := (t, t)) in
     let T' = T @ [Unique] in
     let H' = H @ [(VInt 0, [t])] in
     preallocate' xs (\<Gamma>', T', H'))"
fun preallocate :: "vname list \<Rightarrow> gamma * tags * heap" where
  "preallocate xs = preallocate' xs (\<Gamma>\<^sub>0, [], [])"

value "preallocate [''x'', ''y'']"
value "map (fst (preallocate [''x'', ''y''])) [''x'', ''y'']"

text \<open>Let Isabelle run Unique programs by generating code for the semantics.\<close>

code_pred [show_modes] place_sem .
code_pred [show_modes] operand_sem .
code_pred [show_modes] rvalue_sem .
code_pred [show_modes] com_sem .

subsection \<open>Invalidating a reference\<close>

text \<open>Consider the following Rust program.
\begin{minted}[linenos]{rust}
let mut root = Box::new(42);
let mut px = &mut *root; // reborrowing from root
*px = 100;
let mut py = &mut *root; // another reborrow. invalidates px
*py = 200;
// *px = 300 // this write is invalid.
\end{minted}

In line 1, we create a box that contains 42 in the heap.
In the following two lines, we reborrow from it and use the reference to write.
The interesting part is line 4. In this line, we create a new reference from \rust{root}.
As this reborrow asserts that \rust{py} is the unique reference to the box,
\rust{px} must be invalidated at this point.
Therefore, if we remove the comment in line 6, the program will perform an invalid write
(thus rustc will reject the program).

Let's execute the program with Unique.
The following command is the translation of the program above without the last commented line.\<close>

definition XY :: com where
  "XY =
    (Var ''root'') ::= (Use \<circ> Constant \<circ> VInt) 42;;
    (Var ''px'') ::= (Reborrow \<circ> Var) ''root'';;
    ((Deref \<circ> Var) ''px'') ::= (Use \<circ> Constant \<circ> VInt) 100;;
    (Var ''py'') ::= (Reborrow \<circ> Var) ''root'';;
    ((Deref \<circ> Var) ''py'') ::= (Use \<circ> Constant \<circ> VInt) 200"

text \<open>We can let Isabelle compute the program.\<close>

value "preallocate [''root'', ''px'', ''py'']"
abbreviation "\<Gamma> == \<Gamma>\<^sub>0(''root'' := (0, 0), ''px'' := (1, 1), ''py'' := (2, 2))"
abbreviation "T == [Unique, Unique, Unique]"
abbreviation "H == [(VInt 0, [0]), (VInt 0, [1]), (VInt 0, [2])]"
lemma "preallocate [''root'', ''px'', ''py''] = (\<Gamma>, T, H)" by auto

values "{(T', H') |
         T' H' c'. \<Gamma> \<turnstile> (T, H, XY) \<rightarrow>\<^sup>* (T', H', c')}"

text \<open>The following shows the tags and the heap at the end of execution.\<close>

abbreviation T\<^sub>X\<^sub>Y :: tags where
  "T\<^sub>X\<^sub>Y == [Unique, Unique, Unique, Unique, Unique]" (* 5 variables + 2 reborrows *)
abbreviation H\<^sub>X\<^sub>Y :: heap where
  "H\<^sub>X\<^sub>Y == [(VInt 200, [0, 4]), (Reference 0 3, [1]), (Reference 0 4, [2])]"

text \<open>We can also prove that the program result in the state shown above in theory,
but it's really tedious (why can't Isabelle prove it by computing the execution?).
The actual proof is left to the reader.\<close>

lemma final_xy: "\<Gamma> \<turnstile> (T, H, XY) \<rightarrow>\<^sup>* (T\<^sub>X\<^sub>Y, H\<^sub>X\<^sub>Y, Skip)"
  sorry \<^marker>\<open>tag important\<close>

text \<open>We show that accessing through \rust{px} after the program will stuck.\<close>

lemma intermediate_xyx: "\<Gamma> \<turnstile> (T, H, XY;; ((Deref \<circ> Var) ''px'') ::= (Use \<circ> Constant \<circ> VInt) 300)
  \<rightarrow>\<^sup>* (T\<^sub>X\<^sub>Y, H\<^sub>X\<^sub>Y, ((Deref \<circ> Var) ''px'') ::= (Use \<circ> Constant \<circ> VInt) 300)"
  apply (rule star_trans)
   prefer 2
   apply (rule star_step1)
   apply (rule SeqL)
  apply (rule com_seql_trans)
  apply (rule final_xy)
  done

lemma stuck_xyx: "stuck \<Gamma>
   (T\<^sub>X\<^sub>Y, H\<^sub>X\<^sub>Y, ((Deref \<circ> Var) ''px'') ::= (Use \<circ> Constant \<circ> VInt) 300)"
  apply (simp add: stuck_def)
  apply (rule allI)+
  apply (rule notI)
  apply (rule ComE(1))
   apply (auto)
  done

lemma "\<exists>cfg. (\<Gamma> \<turnstile> (T, H, XY;; ((Deref \<circ> Var) ''px'') ::= (Use \<circ> Constant \<circ> VInt) 300) \<rightarrow>\<^sup>* cfg)
           \<and> stuck \<Gamma> cfg"
  apply (rule exI)
  apply (rule conjI)
   apply (rule intermediate_xyx)
  apply (rule stuck_xyx)
  done

subsection \<open>Swap\<close>

text \<open>The following program swaps the content the given two references pointing to.\<close>

fun swap :: "place \<Rightarrow> place \<Rightarrow> com" where
  "swap x y =
    (Var ''reborrow_x'') ::= Reborrow x;;
    (Var ''reborrow_y'') ::= Reborrow y;;
    (Var ''tmp'') ::= (Use \<circ> Place \<circ> Deref \<circ> Deref \<circ> Var) ''reborrow_x'';;
    ((Deref \<circ> Var) ''reborrow_x'') ::= (Use \<circ> Place \<circ> Deref \<circ> Deref \<circ> Var) ''reborrow_y'';;
    ((Deref \<circ> Var) ''reborrow_y'') ::= (Use \<circ> Place \<circ> Deref \<circ> Deref \<circ> Var) ''tmp''"

text \<open>We can see the content swapped during the execution by running it on Isabelle.\<close>

values "{H | T H c.
  \<Gamma>\<^sub>0(''reborrow_x'' := (0, 0), ''reborrow_y'' := (1, 1), ''tmp'' := (2, 2), ''a'' := (3, 3), ''b'' := (4, 4)) \<turnstile>
  ([Unique, Unique, Unique],
   [(VInt 0, [0]), (VInt 0, [1]), (VInt 0, [2]), (VInt 10000, [3]), (VInt 20000, [4])],
   swap (Var ''a'') (Var ''b'')) \<rightarrow>\<^sup>* (T, H, c)}"

text \<open>Proving the correctness of @{const swap} would need a Hoare Logic. The road continues...\<close>

end


(*  Title:      Native_Word_Test_Emu.thy
    Author:     Andreas Lochbihler, ETH Zurich
*)

theory Native_Word_Test_Emu imports
  Native_Word_Test
  Code_Target_Bits_Int
begin

section \<open>Test cases for emulation of native words\<close>

subsection \<open>Tests for @{typ uint16}\<close>

text \<open>
  Test that @{typ uint16} is emulated for PolyML and OCaml via @{typ "16 word"}
  if @{theory Native_Word.Code_Target_Bits_Int} is imported.
\<close>

definition test_uint16_emulation :: bool where
  "test_uint16_emulation \<longleftrightarrow> (0xFFFFF - 0x1000 = (0xEFFF :: uint16))"

export_code test_uint16_emulation checking SML OCaml?
  \<comment> \<open>test the other target languages as well\<close> Haskell? Scala

notepad begin
have test_uint16 by eval
have test_uint16_emulation by eval
have test_uint16_emulation by normalization
have test_uint16_emulation by code_simp
end

ML_val \<open>
  val true = @{code test_uint16};
  val true = @{code test_uint16_emulation};
\<close>

lemma "x AND y = x OR (y :: uint16)"
quickcheck[random, expect=counterexample]
quickcheck[exhaustive, expect=counterexample]
oops

subsection \<open>Tests for @{typ uint8}\<close>

text \<open>
  Test that @{typ uint8} is emulated for OCaml via @{typ "8 word"}
  if @{theory Native_Word.Code_Target_Bits_Int} is imported.
\<close>

definition test_uint8_emulation :: bool where
  "test_uint8_emulation \<longleftrightarrow> (0xFFF - 0x10 = (0xEF :: uint8))"

export_code test_uint8_emulation checking OCaml?
  \<comment> \<open>test the other target languages as well\<close> SML Haskell? Scala

end


(*
 * Copyright 2019, NTU
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 *  Author: Albert Rizaldi, NTU Singapore
 *)

theory NAND_Hoare_Typed
  imports VHDL_Hoare_Typed NAND_Femto
begin

subsection \<open>Proving @{term "nand3"}: NAND with transport delay \<close>

abbreviation "bval_of_wline tw sig n \<equiv> bval_of (wline_of tw sig n)"
abbreviation "lof_wline tw sig n \<equiv> lval_of (wline_of tw sig n)"

locale scalar_type_nand3 =
  fixes \<Gamma> :: "sig tyenv"
  assumes "\<Gamma> A = Bty" and "\<Gamma> B = Bty" and "\<Gamma> C = Bty"
begin

text \<open>Invariant for NAND: at all times @{term "i"}, the signal @{term "C :: sig"} at @{term "i"}
should be the NAND value of @{term "A :: sig"} and @{term "B :: sig"} at time @{term "i - 1"}.\<close>

definition nand_inv :: "sig assn2" where
  "nand_inv \<equiv> (\<lambda>tw. bval_of_wline tw C (fst tw) \<longleftrightarrow> \<not> (bval_of_wline tw A (fst tw - 1) \<and> bval_of_wline tw B (fst tw - 1)))"

definition nand_inv2 :: "sig assn2" where
  "nand_inv2 \<equiv> (\<lambda>tw. disjnt {A, B} (event_of tw) \<longrightarrow> (\<forall>i > fst tw. bval_of_wline tw C i \<longleftrightarrow> bval_of_wline tw C (fst tw)))"

lemma nand_inv_next_time:
  fixes tw
  defines "v \<equiv> eval_world_raw2 tw (Bnand (Bsig A) (Bsig B))"
  defines "tw' \<equiv> tw[C, 1 :=\<^sub>2 v]"
  assumes "wityping \<Gamma> (snd tw)"
  shows   "nand_inv (fst tw' + 1, snd tw')"
proof -
  have bexpA: "bexp_wt \<Gamma> (Bsig A) Bty" and bexpB: "bexp_wt \<Gamma> (Bsig B) Bty"
    using scalar_type_nand3_axioms unfolding scalar_type_nand3_def  by (metis bexp_wt.intros(3))+
  have "bval_of_wline tw' C (fst tw + 1) \<longleftrightarrow> bval_of v"
    unfolding tw'_def worldline_upd2_def worldline_upd_def by auto
  also have "... \<longleftrightarrow> \<not> (bval_of_wline tw A (fst tw) \<and> bval_of_wline tw B (fst tw))"
    using eval_world_raw_bv[OF bexpA `wityping \<Gamma> (snd tw)`]  eval_world_raw_bv[OF bexpB `wityping \<Gamma> (snd tw)`]
    unfolding v_def by (auto split:val.split)(metis val.distinct(1))+
  finally show ?thesis
    unfolding nand_inv_def
    by (metis (no_types, lifting) add_diff_cancel_right' comp_apply fst_conv less_add_one snd_conv
    tw'_def worldline_upd2_before_dly worldline_upd2_def)
qed

lemma nand_inv2_next_time:
  fixes tw
  defines "v \<equiv> eval_world_raw2 tw (Bnand (Bsig A) (Bsig B))"
  defines "tw' \<equiv> tw[C, 1 :=\<^sub>2 v]"
  shows   "nand_inv2 (fst tw' + 1, snd tw')"
  using assms unfolding nand_inv2_def tw'_def worldline_upd2_def worldline_upd_def by auto

lemma pre_nand_conc_hoare':
  "\<And>tw. nand_inv tw \<and> nand_inv2 tw \<and> disjnt {A, B} (event_of tw) \<Longrightarrow> nand_inv (fst tw + 1, snd tw)"
proof -
  fix tw
  assume "nand_inv tw \<and> nand_inv2 tw \<and> disjnt {A, B} (event_of tw)"
  hence "nand_inv tw" and "nand_inv2 tw" and "disjnt {A, B} (event_of tw)"
    by auto
  have "bval_of_wline tw C (fst tw + 1) \<longleftrightarrow> bval_of_wline tw C (fst tw)"
    using `nand_inv2 tw` `disjnt {A, B} (event_of tw)` unfolding nand_inv2_def
    by (simp add: next_time_world_at_least)
  also have "... \<longleftrightarrow> \<not> (bval_of_wline tw A (fst tw - 1) \<and> bval_of_wline tw B (fst tw - 1))"
    using `nand_inv tw` unfolding nand_inv_def by auto
  also have "... \<longleftrightarrow> \<not> (bval_of_wline tw A (fst tw) \<and> bval_of_wline tw B (fst tw))"
    using `disjnt {A, B} (event_of tw)`  unfolding event_of_alt_def
    by (smt diff_0_eq_0 disjnt_insert1 mem_Collect_eq)
  finally show "nand_inv (fst tw + 1, snd tw)"
    unfolding nand_inv_def by auto
qed

lemma nand_conc_hoare2:
  "\<And>tw. nand_inv2 tw \<and> disjnt {A, B} (event_of tw) \<Longrightarrow> nand_inv2 (fst tw + 1, snd tw)"
  unfolding nand_inv2_def by auto

lemma conc_stmt_wf_nand3:
  "conc_stmt_wf nand3"
  unfolding nand3_def conc_stmt_wf_def by auto

lemma nonneg_delay_conc_nand3:
  "nonneg_delay_conc nand3"
  unfolding nand3_def by auto

lemma nonneg_delay_conc_nand3':
  "nonneg_delay_conc ( process {A, B} : Bassign_trans C (Bnand (Bsig A) (Bsig B)) 1)"
  using nonneg_delay_conc_nand3 unfolding nand3_def by auto

lemma conc_wt_nand3:
  "conc_wt \<Gamma> nand3"
  unfolding nand3_def by (metis bexp_wt.intros(3) bexp_wt.intros(9) conc_wt.intros(1)
  scalar_type_nand3_axioms scalar_type_nand3_def seq_wt.intros(4))

lemma conc_wt_nand3':
  "conc_wt \<Gamma> ( process {A, B} : Bassign_trans C (Bnand (Bsig A) (Bsig B)) 1)"
  using conc_wt_nand3 unfolding nand3_def by auto

lemma nand_conc_sim2':
  "\<Gamma> \<turnstile>\<^sub>s \<lbrace>\<lambda>tw. nand_inv tw \<and> nand_inv2 tw\<rbrace> nand3 \<lbrace>\<lambda>tw. nand_inv tw \<and> nand_inv2 tw\<rbrace>"
  apply (rule While_Suc)
  apply (rule Conseq'[where P="wp3_conc \<Gamma> nand3 (\<lambda>tw. nand_inv  (fst tw + 1, snd tw) \<and>
                                                      nand_inv2 (fst tw + 1, snd tw))", rotated])
  apply (rule wp3_conc_is_pre, rule conc_stmt_wf_nand3, rule nonneg_delay_conc_nand3, rule conc_wt_nand3, simp)
  unfolding nand3_def  wp3_conc_single'[OF conc_wt_nand3' nonneg_delay_conc_nand3'] wp3_fun.simps
  using nand_conc_hoare2 nand_inv2_next_time nand_inv_next_time pre_nand_conc_hoare' by presburger

text \<open>Initialisation preserves the invariant\<close>

lemma seq_wt_nand3':
  "seq_wt \<Gamma> (Bassign_trans C (Bnand (Bsig A) (Bsig B)) 1)"
  using conc_wt_nand3' by auto

lemma nonneg_delay_nand3:
  " nonneg_delay (Bassign_trans C (Bnand (Bsig A) (Bsig B)) 1)"
  using nonneg_delay_conc_nand3' by auto

lemma init_sat_nand_inv_comb:
  "init_sim2_hoare_wt \<Gamma> (\<lambda>tw. fst tw = 0) nand3 (\<lambda>tw. nand_inv tw \<and> nand_inv2 tw)"
  unfolding nand3_def
  apply (rule AssignI_suc, rule SingleI)
  apply (rule Conseq3[where Q="\<lambda>tw. nand_inv (fst tw + 1, snd tw) \<and> nand_inv2 (fst tw + 1, snd tw)", rotated])
  apply (rule wp3_fun_is_pre[OF seq_wt_nand3' nonneg_delay_nand3], simp)
  unfolding wp3_fun.simps using nand_inv_next_time nand_inv2_next_time by blast

lemma nand_correctness:
  assumes "sim_fin2 w (i + 1) nand3 tw'" and "wityping \<Gamma> w"
  shows "bval_of_wline tw' C (i + 1) \<longleftrightarrow> \<not> (bval_of_wline tw' A i \<and> bval_of_wline tw' B i)"
  using grand_correctness[OF assms conc_stmt_wf_nand3 conc_wt_nand3 nonneg_delay_conc_nand3 nand_conc_sim2' init_sat_nand_inv_comb]
  unfolding nand_inv_def by (metis (no_types, lifting) add_diff_cancel_right' assms(1) sim_fin2.cases world_maxtime_lt_fst_tres)

end


theory Proof_System
imports "../basic_theory/Entailment"
begin

section \<open>Rules of the Proof System\<close>
text \<open>The proof system at the core of the decision procedure is based on the following rules.\<close>

theorem axiom: "\<Pi>\<bar>emp \<turnstile> \<top>\<bar>emp"
by (auto simp: entails_def)

theorem inconsistent: "E\<noteq>\<^sub>pE \<and>\<^sub>p \<Pi>\<bar>\<Sigma> \<turnstile> F"
by (auto simp: entails_def)

theorem substitution: "subst x E (\<Pi>\<bar>\<Sigma>) \<turnstile> subst x E (\<Pi>'\<bar>\<Sigma>') \<Longrightarrow> \<acute>x`=\<^sub>pE \<and>\<^sub>p \<Pi>\<bar>\<Sigma> \<turnstile> \<Pi>'\<bar>\<Sigma>'"
proof (rule entailment_lift)
  fix s h
  assume assm1: "subst x E (\<Pi>\<bar>\<Sigma>) \<turnstile> subst x E (\<Pi>'\<bar>\<Sigma>')"
  assume assm2: "(s,h)\<Turnstile>\<acute>x`=\<^sub>pE\<and>\<^sub>p\<Pi>\<bar>\<Sigma>"
  hence s_eq: "\<lbrakk>\<acute>x`\<rbrakk>s=\<lbrakk>E\<rbrakk>s" and "(s,h)\<Turnstile>\<Pi>\<bar>\<Sigma>" by fast+
  hence "(s,h)\<Turnstile>subst x E (\<Pi>\<bar>\<Sigma>)" using subst_sat_rev by blast
  with assm1 have "(s,h)\<Turnstile>subst x E (\<Pi>'\<bar>\<Sigma>')" by (simp add: entails_def)
  with s_eq show "(s,h)\<Turnstile>\<Pi>'\<bar>\<Sigma>'" using subst_sat by blast
qed

theorem eq_reflexivel: "\<Pi>\<bar>\<Sigma> \<turnstile> \<Pi>'\<bar>\<Sigma>' \<Longrightarrow> E=\<^sub>pE\<and>\<^sub>p\<Pi>\<bar>\<Sigma> \<turnstile> \<Pi>'\<bar>\<Sigma>'"
unfolding entails_def by blast

theorem eq_reflexiver: "\<Pi>\<bar>\<Sigma> \<turnstile> \<Pi>'\<bar>\<Sigma>' \<Longrightarrow> \<Pi>\<bar>\<Sigma> \<turnstile> E=\<^sub>pE\<and>\<^sub>p\<Pi>'\<bar>\<Sigma>'"
unfolding entails_def by blast

theorem hypothesis: "P\<and>\<^sub>p\<Pi>\<bar>\<Sigma> \<turnstile> \<Pi>'\<bar>\<Sigma>' \<Longrightarrow> P\<and>\<^sub>p\<Pi>\<bar>\<Sigma> \<turnstile> P\<and>\<^sub>p\<Pi>'\<bar>\<Sigma>'"
unfolding entails_def by blast

theorem empty_ls: "\<Pi>\<bar>\<Sigma> \<turnstile> \<Pi>'\<bar>\<Sigma>' \<Longrightarrow> \<Pi>\<bar>\<Sigma> \<turnstile> \<Pi>'\<bar>ls(E,E)*\<Sigma>'"
unfolding entails_def by fastforce

theorem nil_not_lval: "E\<^sub>1\<noteq>\<^sub>pnil \<and>\<^sub>p \<Pi>\<bar>E\<^sub>1\<longmapsto>E\<^sub>2 * \<Sigma> \<turnstile> \<Pi>'\<bar>\<Sigma>' \<Longrightarrow> \<Pi>\<bar>E\<^sub>1\<longmapsto>E\<^sub>2 * \<Sigma> \<turnstile> \<Pi>'\<bar>\<Sigma>'"
unfolding entails_def by force

theorem sep_conj_partial: "E\<^sub>1\<noteq>\<^sub>pE\<^sub>3 \<and>\<^sub>p \<Pi>\<bar>E\<^sub>1\<longmapsto>E\<^sub>2 * E\<^sub>3\<longmapsto>E\<^sub>4 * \<Sigma> \<turnstile> \<Pi>'\<bar>\<Sigma>'
  \<Longrightarrow> \<Pi>\<bar>E\<^sub>1\<longmapsto>E\<^sub>2 * E\<^sub>3\<longmapsto>E\<^sub>4 * \<Sigma> \<turnstile> \<Pi>'\<bar>\<Sigma>'"
proof (rule entailment_lift)
  fix s h
  assume assm1: "E\<^sub>1\<noteq>\<^sub>pE\<^sub>3 \<and>\<^sub>p \<Pi>\<bar>E\<^sub>1\<longmapsto>E\<^sub>2 * E\<^sub>3\<longmapsto>E\<^sub>4 * \<Sigma> \<turnstile> \<Pi>'\<bar>\<Sigma>'"
  assume assm2: "(s,h)\<Turnstile>\<Pi>\<bar>E\<^sub>1\<longmapsto>E\<^sub>2 * E\<^sub>3\<longmapsto>E\<^sub>4 * \<Sigma>"
  then obtain h1 h2 where "h=h1++h2" "h1\<bottom>h2" "(s,h1)\<Turnstile>Spat(E\<^sub>1\<longmapsto>E\<^sub>2)" "(s,h2)\<Turnstile>SpatF(E\<^sub>3\<longmapsto>E\<^sub>4 * \<Sigma>)"
    by fastforce
  moreover then obtain h3 h4 where "h2=h3++h4" "h3\<bottom>h4" "(s,h3)\<Turnstile>Spat(E\<^sub>3\<longmapsto>E\<^sub>4)" by auto
  ultimately have "\<lbrakk>E\<^sub>1\<rbrakk>s \<noteq> \<lbrakk>E\<^sub>3\<rbrakk>s" by fastforce
  hence "(s,h)\<Turnstile>Pure(E\<^sub>1\<noteq>\<^sub>pE\<^sub>3)" by auto
  with assm2 have "(s,h)\<Turnstile>E\<^sub>1\<noteq>\<^sub>pE\<^sub>3 \<and>\<^sub>p \<Pi>\<bar>E\<^sub>1\<longmapsto>E\<^sub>2 * E\<^sub>3\<longmapsto>E\<^sub>4 * \<Sigma>" by auto
  with assm1 show "(s,h)\<Turnstile>\<Pi>'\<bar>\<Sigma>'" by (simp add: entails_def)
qed

theorem frame: "\<Pi>\<bar>\<Sigma> \<turnstile> \<Pi>'\<bar>\<Sigma>' \<Longrightarrow> \<Pi>\<bar>S * \<Sigma> \<turnstile> \<Pi>'\<bar>S * \<Sigma>'"
proof (rule entailment_lift)
  fix s h
  assume assm1: "\<Pi>\<bar>\<Sigma> \<turnstile> \<Pi>'\<bar>\<Sigma>'"
  assume assm2: "(s,h)\<Turnstile>\<Pi>\<bar>S * \<Sigma>"
  then obtain h1 h2 where sep_conj: "h=h1++h2" "h1\<bottom>h2" "(s,h1)\<Turnstile>Spat S" "(s,h2)\<Turnstile>SpatF \<Sigma>" by fast
  moreover {
    from assm2 have "(s,h)\<Turnstile>PureF \<Pi>" by fastforce
    from heap_puref[OF this] have "(s,h2)\<Turnstile>PureF \<Pi>" by simp
    with sep_conj(4) have "(s,h2)\<Turnstile>\<Pi>\<bar>\<Sigma>" by fast
    with assm1 have "(s,h2)\<Turnstile>\<Pi>'\<bar>\<Sigma>'" by (simp add: entails_def)
    hence "(s,h2)\<Turnstile>PureF \<Pi>'" "(s,h2)\<Turnstile>SpatF \<Sigma>'" by auto
  }
  ultimately show "(s,h)\<Turnstile>\<Pi>'\<bar>S * \<Sigma>'" using heap_puref by blast
qed

theorem non_empty_ls: "E\<^sub>1\<noteq>\<^sub>pE\<^sub>3 \<and>\<^sub>p \<Pi>\<bar>\<Sigma> \<turnstile> \<Pi>'\<bar>ls(E\<^sub>2,E\<^sub>3) * \<Sigma>'
  \<Longrightarrow> E\<^sub>1\<noteq>\<^sub>pE\<^sub>3 \<and>\<^sub>p \<Pi>\<bar>E\<^sub>1\<longmapsto>E\<^sub>2 * \<Sigma> \<turnstile> \<Pi>'\<bar>ls(E\<^sub>1,E\<^sub>3) * \<Sigma>'"
proof (rule entailment_lift)
  define xs where xs: "xs = -(fv E\<^sub>1 \<union> fv E\<^sub>2 \<union> fv E\<^sub>3)"
  fix s h
  assume assm1: "E\<^sub>1\<noteq>\<^sub>pE\<^sub>3 \<and>\<^sub>p \<Pi>\<bar>\<Sigma> \<turnstile> \<Pi>'\<bar>ls(E\<^sub>2,E\<^sub>3) * \<Sigma>'"
  assume assm2: "(s,h)\<Turnstile>E\<^sub>1\<noteq>\<^sub>pE\<^sub>3 \<and>\<^sub>p \<Pi>\<bar>E\<^sub>1\<longmapsto>E\<^sub>2 * \<Sigma>"
  then obtain h1 h2 where sep_conj:"h=h1++h2" "h1\<bottom>h2" "(s,h1)\<Turnstile>Spat(E\<^sub>1\<longmapsto>E\<^sub>2)" "(s,h2)\<Turnstile>SpatF \<Sigma>"
    by fastforce
  then obtain v where hd: "\<lbrakk>E\<^sub>1\<rbrakk>s = Val v" "h1 = [v\<mapsto>\<lbrakk>E\<^sub>2\<rbrakk>s]" by fast
  from assm2 have "\<lbrakk>E\<^sub>1\<rbrakk>s\<noteq>\<lbrakk>E\<^sub>3\<rbrakk>s" by blast
  {
    from assm2 have "(s,h)\<Turnstile>PureF (E\<^sub>1\<noteq>\<^sub>pE\<^sub>3 \<and>\<^sub>p \<Pi>)" by blast
    hence "(s,h2)\<Turnstile>PureF (E\<^sub>1\<noteq>\<^sub>pE\<^sub>3 \<and>\<^sub>p \<Pi>)" using heap_puref by auto
    with sep_conj(4) have "(s,h2)\<Turnstile>(E\<^sub>1\<noteq>\<^sub>pE\<^sub>3 \<and>\<^sub>p \<Pi>)\<bar>\<Sigma>" by auto
    with assm1 have "(s,h2)\<Turnstile>\<Pi>'\<bar>ls(E\<^sub>2,E\<^sub>3) * \<Sigma>'" by (simp add: entails_def)
  }
  then obtain h2_1 h2_2 where sep_conj2:"h2=h2_1++h2_2" "h2_1\<bottom>h2_2" "(s,h2_1)\<Turnstile>Spat (ls(E\<^sub>2,E\<^sub>3))"
    "(s,h2_2)\<Turnstile>SpatF \<Sigma>'" by blast
  then obtain m where tail: "(s,h2_1)\<Turnstile>ls\<^sup>m(E\<^sub>2,E\<^sub>3)" by fast
  then obtain n where n: "n = Suc m" by simp
  have "\<forall>x \<in> xs. (s(x:=\<lbrakk>E\<^sub>2\<rbrakk>s),h2_1)\<Turnstile>ls\<^sup>m(\<acute>x`,E\<^sub>3)"
  proof
    fix x
    assume "x \<in> xs"
    with xs have "x \<notin> fv E\<^sub>2 \<union> fv E\<^sub>3" by fast
    from ls_extend_rhs[OF tail this] have tail_ext: "(s(x:=\<lbrakk>E\<^sub>2\<rbrakk>s),h2_1)\<Turnstile>ls\<^sup>m(E\<^sub>2,E\<^sub>3)" .
    have "\<lbrakk>E\<^sub>2\<rbrakk>s(x:=\<lbrakk>E\<^sub>2\<rbrakk>s) = \<lbrakk>\<acute>x`\<rbrakk>s(x:=\<lbrakk>E\<^sub>2\<rbrakk>s)"
      by (metis eval.simps(1) eval.simps(2) expr.exhaust fun_upd_apply)
    from ls_change_fst[OF tail_ext this] show "(s(x:=\<lbrakk>E\<^sub>2\<rbrakk>s),h2_1)\<Turnstile>ls\<^sup>m(\<acute>x`,E\<^sub>3)" .
  qed
  from sep_conj sep_conj2 have "h1\<bottom>h2_1" by auto
  from xs have "xs \<subseteq> -(fv E\<^sub>1 \<union> fv E\<^sub>3)" by blast
  have "h1++h2_1=h1++h2_1" by simp
  from ListSegment[OF hd \<open>xs \<subseteq> -(fv E\<^sub>1 \<union> fv E\<^sub>3)\<close> \<open>\<forall>x \<in> xs. (s(x:=\<lbrakk>E\<^sub>2\<rbrakk>s),h2_1)\<Turnstile>ls\<^sup>m(\<acute>x`,E\<^sub>3)\<close> \<open>h1\<bottom>h2_1\<close>
    this n \<open>\<lbrakk>E\<^sub>1\<rbrakk>s\<noteq>\<lbrakk>E\<^sub>3\<rbrakk>s\<close>] have "(s,h1++h2_1)\<Turnstile>ls\<^sup>n(E\<^sub>1,E\<^sub>3)" .
  {
    hence "(s,h1++h2_1)\<Turnstile>Spat (ls(E\<^sub>1,E\<^sub>3))" by auto
    moreover from sep_conj(1,2) sep_conj2(1,2) have "h=h1++h2_1++h2_2" "h1++h2_1\<bottom>h2_2" by auto
    ultimately have "(s,h)\<Turnstile>SpatF (ls(E\<^sub>1,E\<^sub>3) * \<Sigma>')" using sep_conj2(4) by blast
  }
  moreover from \<open>(s,h2)\<Turnstile>\<Pi>'\<bar>ls(E\<^sub>2,E\<^sub>3) * \<Sigma>'\<close> have "(s,h)\<Turnstile>PureF \<Pi>'" using heap_puref by fast
  ultimately show "(s,h)\<Turnstile>\<Pi>'\<bar>ls(E\<^sub>1,E\<^sub>3) * \<Sigma>'" by blast
qed

text \<open>The most important rule UnrollCollapse:\<close>
theorem UnrollCollapse:
assumes "E\<^sub>1=\<^sub>pE\<^sub>2 \<and>\<^sub>p \<Pi>\<bar>\<Sigma> \<turnstile> \<Pi>'\<bar>\<Sigma>'"
assumes "E\<^sub>1\<noteq>\<^sub>pE\<^sub>2 \<and>\<^sub>p \<acute>x`\<noteq>\<^sub>pE\<^sub>2 \<and>\<^sub>p \<Pi>\<bar>E\<^sub>1\<longmapsto>\<acute>x` * \<acute>x`\<longmapsto>E\<^sub>2 * \<Sigma> \<turnstile> \<Pi>'\<bar>\<Sigma>'"
assumes "x \<notin> fvl \<Pi> \<union> fv E\<^sub>1 \<union> fv E\<^sub>2 \<union> fvl \<Sigma> \<union> fvl \<Pi>' \<union> fvl \<Sigma>'"
shows "\<Pi>\<bar>ls(E\<^sub>1,E\<^sub>2) * \<Sigma> \<turnstile> \<Pi>'\<bar>\<Sigma>'"
(* As explained in the abstract, I had not enough time to prove this rule in parallel to the proof
   from the original paper. *)
sorry
end


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

section \<open>Theory for a loop primitive like while\<close>

theory Loop
imports HOLCF
begin

definition
  step  :: "('a \<rightarrow> tr) \<rightarrow> ('a \<rightarrow> 'a) \<rightarrow> 'a \<rightarrow> 'a" where
  "step = (LAM b g x. If b\<cdot>x then g\<cdot>x else x)"

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

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

lemma step_def2: "step\<cdot>b\<cdot>g\<cdot>x = If b\<cdot>x then g\<cdot>x else x"
apply (unfold step_def)
apply simp
done

lemma while_def2: "while\<cdot>b\<cdot>g = fix\<cdot>(LAM f x. If b\<cdot>x then f\<cdot>(g\<cdot>x) else x)"
apply (unfold while_def)
apply simp
done

(* ------------------------------------------------------------------------- *)
(* rekursive properties of while                                             *)
(* ------------------------------------------------------------------------- *)

lemma while_unfold: "while\<cdot>b\<cdot>g\<cdot>x = If b\<cdot>x then while\<cdot>b\<cdot>g\<cdot>(g\<cdot>x) else x"
apply (rule trans)
apply (rule while_def2 [THEN fix_eq5])
apply simp
done

lemma while_unfold2: "\<forall>x. while\<cdot>b\<cdot>g\<cdot>x = while\<cdot>b\<cdot>g\<cdot>(iterate k\<cdot>(step\<cdot>b\<cdot>g)\<cdot>x)"
apply (induct_tac k)
apply simp
apply (rule allI)
apply (rule trans)
apply (rule while_unfold)
apply (subst iterate_Suc2)
apply (rule trans)
apply (erule_tac [2] spec)
apply (subst step_def2)
apply (rule_tac p = "b\<cdot>x" in trE)
apply simp
apply (subst while_unfold)
apply (rule_tac s = "UU" and t = "b\<cdot>UU" in ssubst)
apply (erule strictI)
apply simp
apply simp
apply simp
apply (subst while_unfold)
apply simp
done

lemma while_unfold3: "while\<cdot>b\<cdot>g\<cdot>x = while\<cdot>b\<cdot>g\<cdot>(step\<cdot>b\<cdot>g\<cdot>x)"
apply (rule_tac s = "while\<cdot>b\<cdot>g\<cdot>(iterate (Suc 0)\<cdot>(step\<cdot>b\<cdot>g)\<cdot>x)" in trans)
apply (rule while_unfold2 [THEN spec])
apply simp
done

(* ------------------------------------------------------------------------- *)
(* properties of while and iterations                                        *)
(* ------------------------------------------------------------------------- *)

lemma loop_lemma1: "\<lbrakk>\<exists>y. b\<cdot>y = FF; iterate k\<cdot>(step\<cdot>b\<cdot>g)\<cdot>x = UU\<rbrakk>
     \<Longrightarrow> iterate(Suc k)\<cdot>(step\<cdot>b\<cdot>g)\<cdot>x = UU"
apply (simp (no_asm))
apply (rule trans)
apply (rule step_def2)
apply simp
apply (erule exE)
apply (erule flat_codom [THEN disjE])
apply simp_all
done

lemma loop_lemma2: "\<lbrakk>\<exists>y. b\<cdot>y = FF; iterate (Suc k)\<cdot>(step\<cdot>b\<cdot>g)\<cdot>x \<noteq> UU\<rbrakk> \<Longrightarrow>
      iterate k\<cdot>(step\<cdot>b\<cdot>g)\<cdot>x \<noteq> UU"
apply (blast intro: loop_lemma1)
done

lemma loop_lemma3 [rule_format (no_asm)]:
  "\<lbrakk>\<forall>x. INV x \<and> b\<cdot>x = TT \<and> g\<cdot>x \<noteq> UU \<longrightarrow> INV (g\<cdot>x);
         \<exists>y. b\<cdot>y = FF; INV x\<rbrakk>
      \<Longrightarrow> iterate k\<cdot>(step\<cdot>b\<cdot>g)\<cdot>x \<noteq> UU \<longrightarrow> INV (iterate k\<cdot>(step\<cdot>b\<cdot>g)\<cdot>x)"
apply (induct_tac "k")
apply (simp (no_asm_simp))
apply (intro strip)
apply (simp (no_asm) add: step_def2)
apply (rule_tac p = "b\<cdot>(iterate n\<cdot>(step\<cdot>b\<cdot>g)\<cdot>x)" in trE)
apply (erule notE)
apply (simp add: step_def2)
apply (simp (no_asm_simp))
apply (rule mp)
apply (erule spec)
apply (simp (no_asm_simp) del: iterate_Suc add: loop_lemma2)
apply (rule_tac s = "iterate (Suc n)\<cdot>(step\<cdot>b\<cdot>g)\<cdot>x"
  and t = "g\<cdot>(iterate n\<cdot>(step\<cdot>b\<cdot>g)\<cdot>x)" in ssubst)
prefer 2 apply (assumption)
apply (simp add: step_def2)
apply (drule (1) loop_lemma2, simp)
done

lemma loop_lemma4 [rule_format]:
  "\<forall>x. b\<cdot>(iterate k\<cdot>(step\<cdot>b\<cdot>g)\<cdot>x) = FF \<longrightarrow> while\<cdot>b\<cdot>g\<cdot>x = iterate k\<cdot>(step\<cdot>b\<cdot>g)\<cdot>x"
apply (induct_tac k)
apply (simp (no_asm))
apply (intro strip)
apply (simplesubst while_unfold)
apply simp
apply (rule allI)
apply (simplesubst iterate_Suc2)
apply (intro strip)
apply (rule trans)
apply (rule while_unfold3)
apply simp
done

lemma loop_lemma5 [rule_format (no_asm)]:
  "\<forall>k. b\<cdot>(iterate k\<cdot>(step\<cdot>b\<cdot>g)\<cdot>x) \<noteq> FF \<Longrightarrow>
    \<forall>m. while\<cdot>b\<cdot>g\<cdot>(iterate m\<cdot>(step\<cdot>b\<cdot>g)\<cdot>x) = UU"
apply (simplesubst while_def2)
apply (rule fix_ind)
apply simp
apply simp
apply (rule allI)
apply (simp (no_asm))
apply (rule_tac p = "b\<cdot>(iterate m\<cdot>(step\<cdot>b\<cdot>g)\<cdot>x)" in trE)
apply (simp (no_asm_simp))
apply (simp (no_asm_simp))
apply (rule_tac s = "xa\<cdot>(iterate (Suc m)\<cdot>(step\<cdot>b\<cdot>g)\<cdot>x)" in trans)
apply (erule_tac [2] spec)
apply (rule cfun_arg_cong)
apply (rule trans)
apply (rule_tac [2] iterate_Suc [symmetric])
apply (simp add: step_def2)
apply blast
done

lemma loop_lemma6: "\<forall>k. b\<cdot>(iterate k\<cdot>(step\<cdot>b\<cdot>g)\<cdot>x) \<noteq> FF \<Longrightarrow> while\<cdot>b\<cdot>g\<cdot>x = UU"
apply (rule_tac t = "x" in iterate_0 [THEN subst])
apply (erule loop_lemma5)
done

lemma loop_lemma7: "while\<cdot>b\<cdot>g\<cdot>x \<noteq> UU \<Longrightarrow> \<exists>k. b\<cdot>(iterate k\<cdot>(step\<cdot>b\<cdot>g)\<cdot>x) = FF"
apply (blast intro: loop_lemma6)
done

(* ------------------------------------------------------------------------- *)
(* an invariant rule for loops                                               *)
(* ------------------------------------------------------------------------- *)

lemma loop_inv2:
"\<lbrakk>(\<forall>y. INV y \<and> b\<cdot>y = TT \<and> g\<cdot>y \<noteq> UU \<longrightarrow> INV (g\<cdot>y));
    (\<forall>y. INV y \<and> b\<cdot>y = FF \<longrightarrow> Q y);
    INV x; while\<cdot>b\<cdot>g\<cdot>x \<noteq> UU\<rbrakk> \<Longrightarrow> Q (while\<cdot>b\<cdot>g\<cdot>x)"
apply (rule_tac P = "\<lambda>k. b\<cdot>(iterate k\<cdot>(step\<cdot>b\<cdot>g)\<cdot>x) = FF" in exE)
apply (erule loop_lemma7)
apply (simplesubst loop_lemma4)
apply assumption
apply (drule spec, erule mp)
apply (rule conjI)
prefer 2 apply (assumption)
apply (rule loop_lemma3)
apply assumption
apply (blast intro: loop_lemma6)
apply assumption
apply (rotate_tac -1)
apply (simp add: loop_lemma4)
done

lemma loop_inv:
  assumes premP: "P(x)"
    and premI: "\<And>y. P y \<Longrightarrow> INV y"
    and premTT: "\<And>y. \<lbrakk>INV y; b\<cdot>y = TT; g\<cdot>y \<noteq> UU\<rbrakk> \<Longrightarrow> INV (g\<cdot>y)"
    and premFF: "\<And>y. \<lbrakk>INV y; b\<cdot>y = FF\<rbrakk> \<Longrightarrow> Q y"
    and premW: "while\<cdot>b\<cdot>g\<cdot>x \<noteq> UU"
  shows "Q (while\<cdot>b\<cdot>g\<cdot>x)"
apply (rule loop_inv2)
apply (rule_tac [3] premP [THEN premI])
apply (rule_tac [3] premW)
apply (blast intro: premTT)
apply (blast intro: premFF)
done

end