header {* Dyadic Rational Representation of Real *}
theory Float_Real
imports
  "~~/src/HOL/Library/Float"
begin
text {* \label{sec:floatreal} *}

definition Floatreal :: "float \<Rightarrow> real" where "Floatreal = real_of_float"

lemma Floatreal_real[simp]: "Floatreal = real"
  by (simp add: Floatreal_def real_of_float_def)

code_datatype Floatreal

abbreviation
  float_of_nat :: "nat \<Rightarrow> float"
where
  "float_of_nat \<equiv> of_nat"

abbreviation
  float_of_int :: "int \<Rightarrow> float"
where
  "float_of_int \<equiv> of_int"

text{* Collapse nested embeddings *}

lemma Floatreal_of_nat_eq [simp]: "Floatreal (float_of_nat n) = of_nat n"
by (induct n) simp_all

lemma real_of_float_of_nat_eq: "real (of_nat n :: float) = real n"
  using Floatreal_of_nat_eq
  by (simp add: real_of_nat_def)

lemma real_of_float_of_int_eq: "real (float_of_int z) = of_int z"
  by (cases z rule: int_diff_cases) (simp_all add: of_rat_diff real_of_nat_def real_of_float_of_nat_eq)

text {* Operations *}

text {* Undo code setup for @{term Ratreal}. *}

lemma of_rat_numeral_eq [code_abbrev]:
  "Floatreal (numeral w) = Ratreal (numeral w)"
  by simp

lemma zero_real_code [code]:
  "0 = Floatreal 0"
  by simp

lemma one_real_code [code]:
  "1 = Floatreal 1"
  by simp

lemma [code_abbrev]:
  "(Floatreal (of_int a) :: real) = (Ratreal (Rat.of_int a) :: real)"
  by (auto simp: Rat.of_int_def real_of_float_of_int_eq)

lemma [code_abbrev]:
  "Floatreal 0 \<equiv> Ratreal 0"
  by simp

lemma [code_abbrev]:
  "Floatreal 1 = Ratreal 1"
  by simp

lemmas compute_real_of_float[code del]

lemmas [code del] =
  real_equal_code
  real_less_eq_code
  real_less_code
  real_plus_code
  real_times_code
  real_uminus_code
  real_minus_code
  real_inverse_code
  real_divide_code
  real_floor_code

lemma real_equal_code [code]:
  "HOL.equal (Floatreal x) (Floatreal y) \<longleftrightarrow> HOL.equal x y"
  by (metis (poly_guards_query) Floatreal_real equal float_of_real)

abbreviation FloatR::"int\<Rightarrow>int\<Rightarrow>real" where
  "FloatR a b \<equiv> Floatreal (Float a b)"

lemma real_less_eq_code' [code]: "Floatreal x \<le> Floatreal y \<longleftrightarrow> x \<le> y"
  and real_less_code' [code]: "Floatreal x < Floatreal y \<longleftrightarrow> x < y"
  and real_plus_code' [code]: "Floatreal x + Floatreal y = Floatreal (x + y)"
  and real_times_code' [code]: "Floatreal x * Floatreal y = Floatreal (x * y)"
  and real_uminus_code' [code]: "- Floatreal x = Floatreal (- x)"
  and real_minus_code' [code]: "Floatreal x - Floatreal y = Floatreal (x - y)"
  and real_inverse_code' [code]: "inverse (Floatreal x) =
    (if x = 2 then FloatR 1 (-1) else
    Code.abort (STR ''inverse not of 2'') (\<lambda>_. inverse (Floatreal x)))"
  and real_divide_code' [code]: "FloatR a b / Floatreal y =
    (if y = 2 then if a mod 2 = 0 then FloatR (a div 2) b else FloatR a (b - 1) else
    Code.abort (STR ''division not by 2'') (\<lambda>_. FloatR a b / Floatreal y))"
  and real_floor_code' [code]: "floor (Floatreal x) = int_floor_fl x"
  and real_abs_code' [code]: "abs (Floatreal x) = Floatreal (abs x)"
  by (auto simp add: int_floor_fl.rep_eq powr_divide2[symmetric] powr_minus)

lemma compute_round_down[code]: "round_down prec (Floatreal f) = Floatreal (float_down prec f)"
  by simp

lemma compute_round_up[code]: "round_up prec (Floatreal f) = Floatreal (float_up prec f)"
  by simp

lemma compute_truncate_down[code]: "truncate_down prec (Floatreal f) = Floatreal (float_round_down prec f)"
  by (simp add: Float.float_round_down.rep_eq truncate_down_def)

lemma compute_truncate_up[code]: "truncate_up prec (Floatreal f) = Floatreal (float_round_up prec f)"
  by (simp add: float_round_up.rep_eq truncate_up_def)

lemma [code]: "real_divr p (Floatreal x) (Floatreal y) = Floatreal (float_divr p x y)"
  by (simp add: float_divr.rep_eq real_divr_def)

end


(*  Title:      HOL/Proofs/Lambda/ListApplication.thy
    Author:     Tobias Nipkow
    Copyright   1998 TU Muenchen
*)

section \<open>Application of a term to a list of terms\<close>

theory ListApplication imports Lambda begin

abbreviation
  list_application :: "dB => dB list => dB"  (infixl "\<degree>\<degree>" 150) where
  "t \<degree>\<degree> ts == foldl (\<degree>) t ts"

lemma apps_eq_tail_conv [iff]: "(r \<degree>\<degree> ts = s \<degree>\<degree> ts) = (r = s)"
  by (induct ts rule: rev_induct) auto

lemma Var_eq_apps_conv [iff]: "(Var m = s \<degree>\<degree> ss) = (Var m = s \<and> ss = [])"
  by (induct ss arbitrary: s) auto

lemma Var_apps_eq_Var_apps_conv [iff]:
    "(Var m \<degree>\<degree> rs = Var n \<degree>\<degree> ss) = (m = n \<and> rs = ss)"
  apply (induct rs arbitrary: ss rule: rev_induct)
   apply simp
   apply blast
  apply (induct_tac ss rule: rev_induct)
   apply auto
  done

lemma App_eq_foldl_conv:
  "(r \<degree> s = t \<degree>\<degree> ts) =
    (if ts = [] then r \<degree> s = t
    else (\<exists>ss. ts = ss @ [s] \<and> r = t \<degree>\<degree> ss))"
  apply (rule_tac xs = ts in rev_exhaust)
   apply auto
  done

lemma Abs_eq_apps_conv [iff]:
    "(Abs r = s \<degree>\<degree> ss) = (Abs r = s \<and> ss = [])"
  by (induct ss rule: rev_induct) auto

lemma apps_eq_Abs_conv [iff]: "(s \<degree>\<degree> ss = Abs r) = (s = Abs r \<and> ss = [])"
  by (induct ss rule: rev_induct) auto

lemma Abs_apps_eq_Abs_apps_conv [iff]:
    "(Abs r \<degree>\<degree> rs = Abs s \<degree>\<degree> ss) = (r = s \<and> rs = ss)"
  apply (induct rs arbitrary: ss rule: rev_induct)
   apply simp
   apply blast
  apply (induct_tac ss rule: rev_induct)
   apply auto
  done

lemma Abs_App_neq_Var_apps [iff]:
    "Abs s \<degree> t \<noteq> Var n \<degree>\<degree> ss"
  by (induct ss arbitrary: s t rule: rev_induct) auto

lemma Var_apps_neq_Abs_apps [iff]:
    "Var n \<degree>\<degree> ts \<noteq> Abs r \<degree>\<degree> ss"
  apply (induct ss arbitrary: ts rule: rev_induct)
   apply simp
  apply (induct_tac ts rule: rev_induct)
   apply auto
  done

lemma ex_head_tail:
  "\<exists>ts h. t = h \<degree>\<degree> ts \<and> ((\<exists>n. h = Var n) \<or> (\<exists>u. h = Abs u))"
  apply (induct t)
    apply (rule_tac x = "[]" in exI)
    apply simp
   apply clarify
   apply (rename_tac ts1 ts2 h1 h2)
   apply (rule_tac x = "ts1 @ [h2 \<degree>\<degree> ts2]" in exI)
   apply simp
  apply simp
  done

lemma size_apps [simp]:
  "size (r \<degree>\<degree> rs) = size r + foldl (+) 0 (map size rs) + length rs"
  by (induct rs rule: rev_induct) auto

lemma lem0: "[| (0::nat) < k; m <= n |] ==> m < n + k"
  by simp

lemma lift_map [simp]:
    "lift (t \<degree>\<degree> ts) i = lift t i \<degree>\<degree> map (\<lambda>t. lift t i) ts"
  by (induct ts arbitrary: t) simp_all

lemma subst_map [simp]:
    "subst (t \<degree>\<degree> ts) u i = subst t u i \<degree>\<degree> map (\<lambda>t. subst t u i) ts"
  by (induct ts arbitrary: t) simp_all

lemma app_last: "(t \<degree>\<degree> ts) \<degree> u = t \<degree>\<degree> (ts @ [u])"
  by simp

text \<open>\medskip A customized induction schema for \<open>\<degree>\<degree>\<close>.\<close>

lemma lem:
  assumes "!!n ts. \<forall>t \<in> set ts. P t ==> P (Var n \<degree>\<degree> ts)"
    and "!!u ts. [| P u; \<forall>t \<in> set ts. P t |] ==> P (Abs u \<degree>\<degree> ts)"
  shows "size t = n \<Longrightarrow> P t"
  apply (induct n arbitrary: t rule: nat_less_induct)
  apply (cut_tac t = t in ex_head_tail)
  apply clarify
  apply (erule disjE)
   apply clarify
   apply (rule assms)
   apply clarify
   apply (erule allE, erule impE)
    prefer 2
    apply (erule allE, erule mp, rule refl)
   apply simp
   apply (simp only: foldl_conv_fold add.commute fold_plus_sum_list_rev)
   apply (fastforce simp add: sum_list_map_remove1)
  apply clarify
  apply (rule assms)
   apply (erule allE, erule impE)
    prefer 2
    apply (erule allE, erule mp, rule refl)
   apply simp
  apply clarify
  apply (erule allE, erule impE)
   prefer 2
   apply (erule allE, erule mp, rule refl)
  apply simp
  apply (rule le_imp_less_Suc)
  apply (rule trans_le_add1)
  apply (rule trans_le_add2)
  apply (simp only: foldl_conv_fold add.commute fold_plus_sum_list_rev)
  apply (simp add: member_le_sum_list)
  done

theorem Apps_dB_induct:
  assumes "!!n ts. \<forall>t \<in> set ts. P t ==> P (Var n \<degree>\<degree> ts)"
    and "!!u ts. [| P u; \<forall>t \<in> set ts. P t |] ==> P (Abs u \<degree>\<degree> ts)"
  shows "P t"
  apply (rule_tac t = t in lem)
    prefer 3
    apply (rule refl)
    using assms apply iprover+
  done

end


(* VDM to Isabelle Translation @2022-03-01T13:27:00.763152Z
   Copyright 2021, Leo Freitas, leo.freitas@newcastle.ac.uk

in 'CM' (./src/test/resources/Examples/CMSL/CM.vdmsl) at line 11:7
files = [./src/test/resources/Examples/CMSL/CM.vdmsl]
*)
theory CM_POPS1
imports CM
begin

\<comment>\<open>VDM source: Angle = ?\<close>
\<comment>\<open>in 'CM' (./src/test/resources/Examples/CMSL/CM.vdmsl) at line 11:7\<close>
theorem Angle_TOTAL_PO1:
	\<comment>\<open>Implicitly defined type invariant checks for quantified type binds\<close>
	"((\<forall> (num :: VDMNat)  . ((((inv_VDMNat num))) \<longrightarrow> isTest ((inv_Angle num)) (inv_bool))))"
	by simp

\<comment>\<open>VDM source: Angle = ?\<close>
\<comment>\<open>in 'CM' (./src/test/resources/Examples/CMSL/CM.vdmsl) at line 10:3\<close>
theorem Angle_INV_SATISFIABILITY_PO2:
	\<comment>\<open>Implicitly defined type invariant checks for quantified type binds\<close>
	"((\<exists> (num :: VDMNat)  . ((((inv_VDMNat num))) \<longrightarrow> (num \<le> (360::VDMNat1)))))"
	by blast

\<comment>\<open>VDM source: responseDB = ?\<close>
\<comment>\<open>in 'CM' (./src/test/resources/Examples/CMSL/CM.vdmsl) at line 59:5\<close>
theorem responseDB_MAP_SEQ_OF_COMPATIBLE_PO3:
	"((\<forall> m1 \<in> {[MissileType.U_MissileA \<mapsto>[(FlareType.U_FlareOneA  , (900::VDMNat1)) , (FlareType.U_FlareTwoA  , (500::VDMNat1)) , (FlareType.U_DoNothingA  , (100::VDMNat1)) , (FlareType.U_FlareOneA  , (500::VDMNat1))]] , [MissileType.U_MissileB \<mapsto>[(FlareType.U_FlareTwoB  , (500::VDMNat1)) , (FlareType.U_FlareTwoB  , (700::VDMNat1))]] , [MissileType.U_MissileC \<mapsto>[(FlareType.U_FlareOneC  , (400::VDMNat1)) , (FlareType.U_DoNothingC  , (100::VDMNat1)) , (FlareType.U_FlareTwoC  , (400::VDMNat1)) , (FlareType.U_FlareOneC  , (500::VDMNat1))]]}  . (\<forall> m2 \<in> {[MissileType.U_MissileA \<mapsto>[(FlareType.U_FlareOneA  , (900::VDMNat1)) , (FlareType.U_FlareTwoA  , (500::VDMNat1)) , (FlareType.U_DoNothingA  , (100::VDMNat1)) , (FlareType.U_FlareOneA  , (500::VDMNat1))]] , [MissileType.U_MissileB \<mapsto>[(FlareType.U_FlareTwoB  , (500::VDMNat1)) , (FlareType.U_FlareTwoB  , (700::VDMNat1))]] , [MissileType.U_MissileC \<mapsto>[(FlareType.U_FlareOneC  , (400::VDMNat1)) , (FlareType.U_DoNothingC  , (100::VDMNat1)) , (FlareType.U_FlareTwoC  , (400::VDMNat1)) , (FlareType.U_FlareOneC  , (500::VDMNat1))]]}  . (\<forall> d3 \<in> (dom m1)  . (\<forall> d4 \<in> (dom m2)  . ((d3 = d4) \<longrightarrow> ((m1 d3) = (m2 d4))))))))"
	by auto

\<comment>\<open>VDM source: missilePriority = ?\<close>
\<comment>\<open>in 'CM' (./src/test/resources/Examples/CMSL/CM.vdmsl) at line 72:25\<close>
theorem missilePriority_MAP_SEQ_OF_COMPATIBLE_PO4:
	"((\<forall> m1 \<in> {[MissileType.U_MissileA \<mapsto>(1::VDMNat1)] , [MissileType.U_MissileB \<mapsto>(2::VDMNat1)] , [MissileType.U_MissileC \<mapsto>(3::VDMNat1)] , [MissileType.U_None \<mapsto>(0::VDMNat)]}  . (\<forall> m2 \<in> {[MissileType.U_MissileA \<mapsto>(1::VDMNat1)] , [MissileType.U_MissileB \<mapsto>(2::VDMNat1)] , [MissileType.U_MissileC \<mapsto>(3::VDMNat1)] , [MissileType.U_None \<mapsto>(0::VDMNat)]}  . (\<forall> d3 \<in> (dom m1)  . (\<forall> d4 \<in> (dom m2)  . ((d3 = d4) \<longrightarrow> ((m1 d3) = (m2 d4))))))))"
	by auto

\<comment>\<open>VDM source: testval1 = ?\<close>
\<comment>\<open>in 'CM' (./src/test/resources/Examples/CMSL/CM.vdmsl) at line 79:30\<close>
theorem testval1_SUB_TYPE_PO5:
	"((((inv_Angle (88::VDMNat1)) \<and> isTest ((88::VDMNat1)) (inv_VDMNat)) \<and> (((inv_Angle (70::VDMNat1)) \<and> isTest ((70::VDMNat1)) (inv_VDMNat)) \<and> (((inv_Angle (222::VDMNat1)) \<and> isTest ((222::VDMNat1)) (inv_VDMNat)) \<and> ((inv_Angle (44::VDMNat1)) \<and> isTest ((44::VDMNat1)) (inv_VDMNat))))))"
	unfolding inv_Angle_defs by simp

\<comment>\<open>VDM source: testval2 = ?\<close>
\<comment>\<open>in 'CM' (./src/test/resources/Examples/CMSL/CM.vdmsl) at line 84:30\<close>
theorem testval2_SUB_TYPE_PO6:
	"((((inv_Angle (188::VDMNat1)) \<and> isTest ((188::VDMNat1)) (inv_VDMNat)) \<and> (((inv_Angle (70::VDMNat1)) \<and> isTest ((70::VDMNat1)) (inv_VDMNat)) \<and> (((inv_Angle (2::VDMNat1)) \<and> isTest ((2::VDMNat1)) (inv_VDMNat)) \<and> ((inv_Angle (44::VDMNat1)) \<and> isTest ((44::VDMNat1)) (inv_VDMNat))))))"

	unfolding inv_Angle_defs by simp

\<comment>\<open>VDM source: testval3 = ?\<close>
\<comment>\<open>in 'CM' (./src/test/resources/Examples/CMSL/CM.vdmsl) at line 89:30\<close>
theorem testval3_SUB_TYPE_PO7:
	"((((inv_Angle (288::VDMNat1)) \<and> isTest ((288::VDMNat1)) (inv_VDMNat)) \<and> (((inv_Angle (170::VDMNat1)) \<and> isTest ((170::VDMNat1)) (inv_VDMNat)) \<and> (((inv_Angle (222::VDMNat1)) \<and> isTest ((222::VDMNat1)) (inv_VDMNat)) \<and> ((inv_Angle (44::VDMNat1)) \<and> isTest ((44::VDMNat1)) (inv_VDMNat))))))"

	unfolding inv_Angle_defs by simp

	(*
	\<comment>\<open>VDM proof obligation `RelativeToAbsoluteTimes_measure_RelativeToAbsoluteTimes` is spurious given Isabelle's encoding of `measures`.\<close>

\<comment>\<open>VDM source: RelativeToAbsoluteTimes; measure_RelativeToAbsoluteTimes = ?\<close>
\<comment>\<open>in 'CM' (./src/test/resources/Examples/CMSL/CM.vdmsl) at line 130:9\<close>
theorem RelativeToAbsoluteTimes_measure_RelativeToAbsoluteTimes_TOTAL_PO8:
	\<comment>\<open>Implicitly defined type invariant checks for quantified type binds\<close>
	"((\<forall> (ts :: Response VDMSeq)  . ((((inv_VDMSeq' inv_Response ts))) \<longrightarrow> isTest ((measure_RelativeToAbsoluteTimes ts)) (inv_VDMNat))))"

	oops

	*)

\<comment>\<open>VDM source: RelativeToAbsoluteTimes; f, t = ?\<close>
\<comment>\<open>in 'CM' (./src/test/resources/Examples/CMSL/CM.vdmsl) at line 123:26\<close>
theorem RelativeToAbsoluteTimes_f_t_NON_EMPTY_SEQ_PO9:
	\<comment>\<open>Implicitly defined type invariant checks for quantified type binds\<close>
	"((\<forall> (ts :: Response VDMSeq)  . ((((inv_VDMSeq' inv_Response ts))) \<longrightarrow> ((\<not> (ts = [])) \<longrightarrow> (ts \<noteq> [])))))"
	by meson

	(*
	\<comment>\<open>VDM proof obligation `RelativeToAbsoluteTimes_ns` is spurious given Isabelle's encoding of `measures`.\<close>

\<comment>\<open>VDM source: RelativeToAbsoluteTimes; ns = ?\<close>
\<comment>\<open>in 'CM' (./src/test/resources/Examples/CMSL/CM.vdmsl) at line 118:1\<close>
theorem RelativeToAbsoluteTimes_ns_RECURSIVE_PO10:
	\<comment>\<open>Implicitly defined type invariant checks for quantified type binds\<close>
	"((\<forall> (ts :: Response VDMSeq)  . ((((inv_VDMSeq' inv_Response ts))) \<longrightarrow> ((\<not> (ts = [])) \<longrightarrow> ((measure_RelativeToAbsoluteTimes ts) > (measure_RelativeToAbsoluteTimes (tl ts)))))))"

	oops

	*)

\<comment>\<open>VDM source: RelativeToAbsoluteTimes; ns = ?\<close>
\<comment>\<open>in 'CM' (./src/test/resources/Examples/CMSL/CM.vdmsl) at line 125:44\<close>
theorem RelativeToAbsoluteTimes_ns_NON_EMPTY_SEQ_PO11:
	\<comment>\<open>Implicitly defined type invariant checks for quantified type binds\<close>
	"((\<forall> (ts :: Response VDMSeq)  . ((((inv_VDMSeq' inv_Response ts))) \<longrightarrow> ((\<not> (ts = [])) \<longrightarrow> (ts \<noteq> [])))))"
	by blast

\<comment>\<open>VDM source: OutputAtTimeZero; firstFlare = ?\<close>
\<comment>\<open>in 'CM' (./src/test/resources/Examples/CMSL/CM.vdmsl) at line 136:32\<close>
theorem OutputAtTimeZero_firstFlare_NON_EMPTY_SEQ_PO12:
	\<comment>\<open>Implicitly defined type invariant checks for quantified type binds\<close>
	"((\<forall> (response :: Response VDMSeq)  . ((((inv_VDMSeq' inv_Response response))) \<longrightarrow> (
		let
(absTimes::(FlareType \<times> VDMNat) VDMSeq) = (RelativeToAbsoluteTimes response)
		in

			(if ((inv_VDMSeq'
		(\<lambda> (dummy1of2, dummy2of2) . (((inv_True dummy1of2)))\<and>
		 (inv_VDMNat dummy2of2)
		) absTimes)) then
			(absTimes \<noteq> [])
		 else
			undefined
		)
		))))"
	nitpick
	oops

lemma l_CM_AbsTimes_inds: "i \<in> {2..len s} \<Longrightarrow> i - 1 \<in> inds s"
  by (simp add: l_inds_upto)

lemma l_CM_AbsTimes_post: "inv_VDMSeq' inv_Response response \<Longrightarrow> inv_VDMSeq' (\<lambda>(dummy1of2, y). inv_VDMNat y) (RelativeToAbsoluteTimes response)"
  apply (induct response)
   apply (simp add: inv_VDMSeq'_defs)
  thm RelativeToAbsoluteTimes.simps
  oops

lemma l_CM_AbsTimes_post_l0: "inv_VDMSeq' inv_Response response \<Longrightarrow> response \<noteq> [] \<Longrightarrow>
  RelativeToAbsoluteTimes response = [hd response] @ [ (fst n, snd n + snd (hd response)) . n \<leftarrow> tl response ]"
\<comment> \<open>@LF hard lemma about the inner property of \<^term>\<open>RelativeToAbsoluteTimes\<close>\<close>
  sorry

lemma l_CM_AbsTimes_post_l1: "inv_VDMSeq' inv_Response response \<Longrightarrow> response \<noteq> [] \<Longrightarrow> inv_VDMSeq' (\<lambda>(dummy1of2, y). inv_VDMNat y) (RelativeToAbsoluteTimes response)"
  apply (simp add: l_CM_AbsTimes_post_l0[of response] del: RelativeToAbsoluteTimes.simps)
  apply (simp add: inv_VDMSeq'_defs list_all_def inv_Response_defs)
  apply safe
   apply (metis hd_in_set snd_conv)
  by (meson add_increasing list.set_sel(1) list.set_sel(2))

lemma l_CM_AbsTimes_post: "inv_VDMSeq' inv_Response response \<Longrightarrow> inv_VDMSeq' (\<lambda>(dummy1of2, y). inv_VDMNat y) (RelativeToAbsoluteTimes response)"
  apply (induct response)
   apply (simp add: inv_VDMSeq'_defs)
  apply (rule l_CM_AbsTimes_post_l1)
  by simp_all

lemma l_CM_AbsTimes_post': "inv_VDMSeq' inv_Response response \<Longrightarrow>
       inv_VDMNat (snd (hd (RelativeToAbsoluteTimes response)))"
  nitpick
  oops

\<comment>\<open>VDM source: OutputAtTimeZero; t = ?\<close>
\<comment>\<open>in 'CM' (./src/test/resources/Examples/CMSL/CM.vdmsl) at line 138:24\<close>
theorem OutputAtTimeZero_t_SEQ_APPLY_PO13:
	\<comment>\<open>Implicitly defined type invariant checks for quantified type binds\<close>
	"((\<forall> (response :: Response VDMSeq)  . ((((inv_VDMSeq' inv_Response response))) \<longrightarrow> (
		let
(absTimes::(FlareType \<times> VDMNat) VDMSeq) = (RelativeToAbsoluteTimes response)
		in

			(if ((inv_VDMSeq'
		(\<lambda> (dummy1of2, dummy2of2) . (((inv_True dummy1of2)))\<and>
		 (inv_VDMNat dummy2of2)
		) absTimes)) then
			(
		let
	\<comment>\<open>Implicit pattern context projection for `let-bind definition`\<close>

(dummy0::(FlareType \<times> VDMNat)) = (hd absTimes)
		in
			\<comment>\<open>Implicit pattern context projection for `pattern list`\<close>
	 let firstFlare = (fst dummy0); dummy0_ignore = (snd dummy0) in
			(if (
		((((inv_True (fst dummy0))))\<and>
		 (inv_VDMNat (snd dummy0))
		)) then
			(\<forall>
		i \<in> {(2::VDMNat1)..(len absTimes)}

		.
		((i - (1::VDMNat1)) \<in> (inds absTimes)))
		 else
			undefined
		)
		)
		 else
			undefined
		)
		))))"
	apply (safe, simp del: RelativeToAbsoluteTimes.simps add: Let_def, safe)
	  apply (meson l_CM_AbsTimes_inds)
  using l_CM_AbsTimes_post apply blast
  nitpick
	oops

\<comment>\<open>VDM source: OutputAtTimeZero; f = ?\<close>
\<comment>\<open>in 'CM' (./src/test/resources/Examples/CMSL/CM.vdmsl) at line 139:24\<close>
theorem OutputAtTimeZero_f_SEQ_APPLY_PO14:
	\<comment>\<open>Implicitly defined type invariant checks for quantified type binds\<close>
	"((\<forall> (response :: Response VDMSeq)  . ((((inv_VDMSeq' inv_Response response))) \<longrightarrow> (
		let
(absTimes::(FlareType \<times> VDMNat) VDMSeq) = (RelativeToAbsoluteTimes response)
		in

			(if ((inv_VDMSeq'
		(\<lambda> (dummy1of2, dummy2of2) . (((inv_True dummy1of2)))\<and>
		 (inv_VDMNat dummy2of2)
		) absTimes)) then
			(
		let
	\<comment>\<open>Implicit pattern context projection for `let-bind definition`\<close>

(dummy0::(FlareType \<times> VDMNat)) = (hd absTimes)
		in
			\<comment>\<open>Implicit pattern context projection for `pattern list`\<close>
	 let firstFlare = (fst dummy0); dummy0_ignore = (snd dummy0) in
			(if (
		((((inv_True (fst dummy0))))\<and>
		 (inv_VDMNat (snd dummy0))
		)) then
			(\<forall>
		i \<in> {(2::VDMNat1)..(len absTimes)}

		.
		(i \<in> (inds absTimes)))
		 else
			undefined
		)
		)
		 else
			undefined
		)
		))))"
	nitpick
	oops

\<comment>\<open>VDM source: OutputAtTimeZero'; firstFlare = ?\<close>
\<comment>\<open>in 'CM' (./src/test/resources/Examples/CMSL/CM.vdmsl) at line 149:32\<close>
theorem OutputAtTimeZero'_firstFlare_NON_EMPTY_SEQ_PO15:
	\<comment>\<open>Implicitly defined type invariant checks for quantified type binds\<close>
	"((\<forall> (response :: Response VDMSeq)  . ((((inv_VDMSeq' inv_Response response))) \<longrightarrow> (
		let
(absTimes::(FlareType \<times> VDMNat) VDMSeq) = (RelativeToAbsoluteTimes response)
		in

			(if ((inv_VDMSeq'
		(\<lambda> (dummy1of2, dummy2of2) . (((inv_True dummy1of2)))\<and>
		 (inv_VDMNat dummy2of2)
		) absTimes)) then
			(absTimes \<noteq> [])
		 else
			undefined
		)
		))))"
	nitpick
	oops

\<comment>\<open>VDM source: OutputAtTimeZero' = ?\<close>
\<comment>\<open>in 'CM' (./src/test/resources/Examples/CMSL/CM.vdmsl) at line 151:13\<close>
theorem OutputAtTimeZero'_SEQ_APPLY_PO16:
	\<comment>\<open>Implicitly defined type invariant checks for quantified type binds\<close>
	"((\<forall> (response :: Response VDMSeq)  . ((((inv_VDMSeq' inv_Response response))) \<longrightarrow> (
		let
(absTimes::(FlareType \<times> VDMNat) VDMSeq) = (RelativeToAbsoluteTimes response)
		in

			(if ((inv_VDMSeq'
		(\<lambda> (dummy1of2, dummy2of2) . (((inv_True dummy1of2)))\<and>
		 (inv_VDMNat dummy2of2)
		) absTimes)) then
			(
		let
	\<comment>\<open>Implicit pattern context projection for `let-bind definition`\<close>

(dummy0::(FlareType \<times> VDMNat)) = (hd absTimes)
		in
			\<comment>\<open>Implicit pattern context projection for `pattern list`\<close>
	 let firstFlare = (fst dummy0); dummy0_ignore = (snd dummy0) in
			(if (
		((((inv_True (fst dummy0))))\<and>
		 (inv_VDMNat (snd dummy0))
		)) then
			(\<forall>
		i \<in> {(2::VDMNat1)..(len absTimes)}

		.
		(i \<in> (inds absTimes)))
		 else
			undefined
		)
		)
		 else
			undefined
		)
		))))"
	nitpick
	oops

\<comment>\<open>VDM source: OutputAtTimeZero' = ?\<close>
\<comment>\<open>in 'CM' (./src/test/resources/Examples/CMSL/CM.vdmsl) at line 151:29\<close>
theorem OutputAtTimeZero'_SEQ_APPLY_PO17:
	\<comment>\<open>Implicitly defined type invariant checks for quantified type binds\<close>
	"((\<forall> (response :: Response VDMSeq)  . ((((inv_VDMSeq' inv_Response response))) \<longrightarrow> (
		let
(absTimes::(FlareType \<times> VDMNat) VDMSeq) = (RelativeToAbsoluteTimes response)
		in

			(if ((inv_VDMSeq'
		(\<lambda> (dummy1of2, dummy2of2) . (((inv_True dummy1of2)))\<and>
		 (inv_VDMNat dummy2of2)
		) absTimes)) then
			(
		let
	\<comment>\<open>Implicit pattern context projection for `let-bind definition`\<close>

(dummy0::(FlareType \<times> VDMNat)) = (hd absTimes)
		in
			\<comment>\<open>Implicit pattern context projection for `pattern list`\<close>
	 let firstFlare = (fst dummy0); dummy0_ignore = (snd dummy0) in
			(if (
		((((inv_True (fst dummy0))))\<and>
		 (inv_VDMNat (snd dummy0))
		)) then
			(\<forall>
		i \<in> {(2::VDMNat1)..(len absTimes)}

		.
		((i - (1::VDMNat1)) \<in> (inds absTimes)))
		 else
			undefined
		)
		)
		 else
			undefined
		)
		))))"
	nitpick
	oops

\<comment>\<open>VDM source: InterruptPlan = ?\<close>
\<comment>\<open>in 'CM' (./src/test/resources/Examples/CMSL/CM.vdmsl) at line 165:41\<close>
theorem InterruptPlan_MAP_APPLY_PO18:
	\<comment>\<open>Implicitly defined type invariant checks for quantified type binds\<close>
	"((\<forall> (curTime :: VDMNat)   (expOutput :: Output)   (plan :: Plan)   (magid :: MagId)  . ((((inv_VDMNat curTime)))  \<and>  (((inv_Output expOutput)))  \<and>  (((inv_Plan plan)))  \<and>  (((inv_MagId magid))) \<longrightarrow> ((magid \<in> (dom expOutput)) \<longrightarrow> (magid \<in> (dom expOutput))))))"

	by blast

\<comment>\<open>VDM source: InterruptPlan = ?\<close>
\<comment>\<open>in 'CM' (./src/test/resources/Examples/CMSL/CM.vdmsl) at line 164:3\<close>
theorem InterruptPlan_MAP_COMPATIBLE_PO19:
	\<comment>\<open>Implicitly defined type invariant checks for quantified type binds\<close>
	"((\<forall> (curTime :: VDMNat)   (expOutput :: Output)   (plan :: Plan)   (magid :: MagId)  . ((((inv_VDMNat curTime)))  \<and>  (((inv_Output expOutput)))  \<and>  (((inv_Plan plan)))  \<and>  (((inv_MagId magid))) \<longrightarrow> (\<forall> ldom1 \<in> (dom [magid\<mapsto>((
		if ((magid \<in> (dom expOutput))) then
		((LeavePrefixUnchanged ((the(expOutput magid)))  curTime))
		else
		([])) @ (MakeOutputFromPlan curTime  plan))])  . (\<forall> rdom2 \<in> (dom ({magid} -\<triangleleft> expOutput))  . ((ldom1 = rdom2) \<longrightarrow> (((the([magid\<mapsto>((
		if ((magid \<in> (dom expOutput))) then
		((LeavePrefixUnchanged ((the(expOutput magid)))  curTime))
		else
		([])) @ (MakeOutputFromPlan curTime  plan))] ldom1))) = ((the(({magid} -\<triangleleft> expOutput) rdom2))))))))))"
	by (simp add: l_dom_dom_ar)

	(*
	\<comment>\<open>VDM proof obligation `CM_measure_CM` is spurious given Isabelle's encoding of `measures`.\<close>

\<comment>\<open>VDM source: CM; measure_CM = ?\<close>
\<comment>\<open>in 'CM' (./src/test/resources/Examples/CMSL/CM.vdmsl) at line 197:9\<close>
theorem CM_measure_CM_TOTAL_PO20:
	\<comment>\<open>Implicitly defined type invariant checks for quantified type binds\<close>
	"((\<forall> (missileInputs :: MissileInputs)   (outputSoFar :: Output)   (lastMissile :: (MagId \<rightharpoonup> MissileType option))   (curTime :: VDMNat)  . ((((inv_MissileInputs missileInputs)))  \<and>  (((inv_Output outputSoFar)))  \<and>  (((inv_Map inv_MagId (inv_Option inv_MissileType) lastMissile)))  \<and>  (((inv_VDMNat curTime))) \<longrightarrow> isTest ((measure_CM missileInputs  outputSoFar  lastMissile  curTime)) (inv_VDMNat))))"

	oops

	*)

\<comment>\<open>VDM source: CM; curMis, angle = ?\<close>
\<comment>\<open>in 'CM' (./src/test/resources/Examples/CMSL/CM.vdmsl) at line 177:35\<close>
theorem CM_curMis_angle_NON_EMPTY_SEQ_PO21:
	\<comment>\<open>Implicitly defined type invariant checks for quantified type binds\<close>
	"((\<forall> (missileInputs :: MissileInputs)   (outputSoFar :: Output)   (lastMissile :: (MagId \<rightharpoonup> MissileType option))   (curTime :: VDMNat)  . ((((inv_MissileInputs missileInputs)))  \<and>  (((inv_Output outputSoFar)))  \<and>  (((inv_Map inv_MagId (inv_Option inv_MissileType) lastMissile)))  \<and>  (((inv_VDMNat curTime))) \<longrightarrow> ((\<not> (missileInputs = [])) \<longrightarrow> (missileInputs \<noteq> [])))))"
	by meson

lemma l_CM_MAP_APPLY_l1: "list_all inv_True a"
  using inv_SeqElems_def l_invSeqElems_inv_True_True by blast

lemma l_CM_MAP_APPLY_l2: "inv_VDMToken' (inv_VDMSeq' inv_VDMChar) t"
  unfolding inv_VDMToken'_def inv_VDMSeq'_defs inv_VDMChar_def
  by (metis VDMToken.case VDMToken.exhaust l_CM_MAP_APPLY_l1)

\<comment>\<open>VDM source: CM = ?\<close>
\<comment>\<open>in 'CM' (./src/test/resources/Examples/CMSL/CM.vdmsl) at line 185:14\<close>
theorem CM_MAP_APPLY_PO22:
	\<comment>\<open>Implicitly defined type invariant checks for quantified type binds\<close>
	"((\<forall> (missileInputs :: MissileInputs)   (outputSoFar :: Output)   (lastMissile :: (MagId \<rightharpoonup> MissileType option))   (curTime :: VDMNat)  . ((((inv_MissileInputs missileInputs)))  \<and>  (((inv_Output outputSoFar)))  \<and>  (((inv_Map inv_MagId (inv_Option inv_MissileType) lastMissile)))  \<and>  (((inv_VDMNat curTime))) \<longrightarrow> ((\<not> (missileInputs = [])) \<longrightarrow> (
		let
	\<comment>\<open>Implicit pattern context projection for `let-bind definition`\<close>

(dummy0::MissileInput) = (hd missileInputs)
		in
			\<comment>\<open>Implicit pattern context projection for `pattern list`\<close>
	 let curMis = (fst dummy0); angle = (snd dummy0) in
			(if (inv_MissileInput dummy0) then
			(
		let
(magid::MagId) = (Angle2MagId angle)
		in

			(if (inv_MagId magid) then
			((\<not> (magid \<notin> (dom lastMissile))) \<longrightarrow> ((magid \<in> (dom lastMissile)) \<longrightarrow> (curMis \<in> (dom missilePriority))))
		 else
			undefined
		)
		)
		 else
			undefined
		)
		)))))"
	apply (simp add: Let_def, safe)
	  apply (meson MissileType.exhaust)
	unfolding inv_MissileInputs_defs inv_VDMSeq'_def list_all_def apply simp
  apply (erule_tac x="(hd missileInputs)" in ballE)
   apply safe
  apply force+
  using inv_MagId_defs Angle2MagId_def l_CM_MAP_APPLY_l2 by simp

\<comment>\<open>VDM source: CM = ?\<close>
\<comment>\<open>in 'CM' (./src/test/resources/Examples/CMSL/CM.vdmsl) at line 186:14\<close>
theorem CM_MAP_APPLY_PO23:
	\<comment>\<open>Implicitly defined type invariant checks for quantified type binds\<close>
	"((\<forall> (missileInputs :: MissileInputs)   (outputSoFar :: Output)   (lastMissile :: (MagId \<rightharpoonup> MissileType option))   (curTime :: VDMNat)  . ((((inv_MissileInputs missileInputs)))  \<and>  (((inv_Output outputSoFar)))  \<and>  (((inv_Map inv_MagId (inv_Option inv_MissileType) lastMissile)))  \<and>  (((inv_VDMNat curTime))) \<longrightarrow> ((\<not> (missileInputs = [])) \<longrightarrow> (
		let
	\<comment>\<open>Implicit pattern context projection for `let-bind definition`\<close>

(dummy0::MissileInput) = (hd missileInputs)
		in
			\<comment>\<open>Implicit pattern context projection for `pattern list`\<close>
	 let curMis = (fst dummy0); angle = (snd dummy0) in
			(if (inv_MissileInput dummy0) then
			(
		let
(magid::MagId) = (Angle2MagId angle)
		in

			(if (inv_MagId magid) then
			((\<not> (magid \<notin> (dom lastMissile))) \<longrightarrow> ((magid \<in> (dom lastMissile)) \<longrightarrow> (((the((the(lastMissile magid))))) \<in> (dom missilePriority))))
		 else
			undefined
		)
		)
		 else
			undefined
		)
		)))))"
	by (smt (z3) CM_MAP_APPLY_PO22 MissileType.exhaust domIff fun_upd_same l_inmapupd_dom option.distinct(1))

\<comment>\<open>VDM source: CM = ?\<close>
\<comment>\<open>in 'CM' (./src/test/resources/Examples/CMSL/CM.vdmsl) at line 186:30\<close>
theorem CM_SUB_TYPE_PO24:
	\<comment>\<open>Implicitly defined type invariant checks for quantified type binds\<close>
	"((\<forall> (missileInputs :: MissileInputs)   (outputSoFar :: Output)   (lastMissile :: (MagId \<rightharpoonup> MissileType option))   (curTime :: VDMNat)  . ((((inv_MissileInputs missileInputs)))  \<and>  (((inv_Output outputSoFar)))  \<and>  (((inv_Map inv_MagId (inv_Option inv_MissileType) lastMissile)))  \<and>  (((inv_VDMNat curTime))) \<longrightarrow> ((\<not> (missileInputs = [])) \<longrightarrow> (
		let
	\<comment>\<open>Implicit pattern context projection for `let-bind definition`\<close>

(dummy0::MissileInput) = (hd missileInputs)
		in
			\<comment>\<open>Implicit pattern context projection for `pattern list`\<close>
	 let curMis = (fst dummy0); angle = (snd dummy0) in
			(if (inv_MissileInput dummy0) then
			(
		let
(magid::MagId) = (Angle2MagId angle)
		in

			(if (inv_MagId magid) then
			((\<not> (magid \<notin> (dom lastMissile))) \<longrightarrow> ((magid \<in> (dom lastMissile)) \<longrightarrow> (isTest (((the((the(lastMissile magid)))))) (inv_True) \<or> (isTest (((the((the(lastMissile magid)))))) (inv_True) \<or> (isTest (((the((the(lastMissile magid)))))) (inv_True) \<or> isTest (((the((the(lastMissile magid)))))) (inv_True))))))
		 else
			undefined
		)
		)
		 else
			undefined
		)
		)))))"
	by (metis CM_MAP_APPLY_PO22 inv_True_def isTest_def)

\<comment>\<open>VDM source: CM = ?\<close>
\<comment>\<open>in 'CM' (./src/test/resources/Examples/CMSL/CM.vdmsl) at line 186:30\<close>
theorem CM_MAP_APPLY_PO25:
	\<comment>\<open>Implicitly defined type invariant checks for quantified type binds\<close>
	"((\<forall> (missileInputs :: MissileInputs)   (outputSoFar :: Output)   (lastMissile :: (MagId \<rightharpoonup> MissileType option))   (curTime :: VDMNat)  . ((((inv_MissileInputs missileInputs)))  \<and>  (((inv_Output outputSoFar)))  \<and>  (((inv_Map inv_MagId (inv_Option inv_MissileType) lastMissile)))  \<and>  (((inv_VDMNat curTime))) \<longrightarrow> ((\<not> (missileInputs = [])) \<longrightarrow> (
		let
	\<comment>\<open>Implicit pattern context projection for `let-bind definition`\<close>

(dummy0::MissileInput) = (hd missileInputs)
		in
			\<comment>\<open>Implicit pattern context projection for `pattern list`\<close>
	 let curMis = (fst dummy0); angle = (snd dummy0) in
			(if (inv_MissileInput dummy0) then
			(
		let
(magid::MagId) = (Angle2MagId angle)
		in

			(if (inv_MagId magid) then
			((\<not> (magid \<notin> (dom lastMissile))) \<longrightarrow> ((magid \<in> (dom lastMissile)) \<longrightarrow> (magid \<in> (dom lastMissile))))
		 else
			undefined
		)
		)
		 else
			undefined
		)
		)))))"
	by (meson CM_MAP_APPLY_PO22)

\<comment>\<open>VDM source: CM; newOutput = ?\<close>
\<comment>\<open>in 'CM' (./src/test/resources/Examples/CMSL/CM.vdmsl) at line 189:36\<close>
theorem CM_newOutput_MAP_APPLY_PO26:
	\<comment>\<open>Implicitly defined type invariant checks for quantified type binds\<close>
	"((\<forall> (missileInputs :: MissileInputs)   (outputSoFar :: Output)   (lastMissile :: (MagId \<rightharpoonup> MissileType option))   (curTime :: VDMNat)  . ((((inv_MissileInputs missileInputs)))  \<and>  (((inv_Output outputSoFar)))  \<and>  (((inv_Map inv_MagId (inv_Option inv_MissileType) lastMissile)))  \<and>  (((inv_VDMNat curTime))) \<longrightarrow> ((\<not> (missileInputs = [])) \<longrightarrow> (
		let
	\<comment>\<open>Implicit pattern context projection for `let-bind definition`\<close>

(dummy0::MissileInput) = (hd missileInputs)
		in
			\<comment>\<open>Implicit pattern context projection for `pattern list`\<close>
	 let curMis = (fst dummy0); angle = (snd dummy0) in
			(if (inv_MissileInput dummy0) then
			(
		let
(magid::MagId) = (Angle2MagId angle)
		in

			(if (inv_MagId magid) then
			(((magid \<notin> (dom lastMissile)) \<or> ((magid \<in> (dom lastMissile)) \<and> (((the(missilePriority curMis))) > ((the(missilePriority ((the((the(lastMissile magid))))))))))) \<longrightarrow> (curMis \<in> (dom responseDB)))
		 else
			undefined
		)
		)
		 else
			undefined
		)
		)))))"

	apply (simp add: Let_def, safe)
  \<comment> \<open>@LF clear consequence of multiple let-defs! Safe = 41 goals\<close>
                      apply (meson CM_MAP_APPLY_PO22)
  using inv_MagId_def l_CM_MAP_APPLY_l2 apply blast
                      apply (meson CM_MAP_APPLY_PO25)
  using inv_MagId_def l_CM_MAP_APPLY_l2 apply blast
                      apply (meson CM_MAP_APPLY_PO25)
  using inv_MagId_def l_CM_MAP_APPLY_l2 apply blast
  apply (rule_tac x="(Some U_MissileA)" in exI)
  defer
                      apply (meson CM_MAP_APPLY_PO25)
  using inv_MagId_def l_CM_MAP_APPLY_l2 apply blast
                      defer
                      apply (meson CM_MAP_APPLY_PO25)
  using inv_MagId_def l_CM_MAP_APPLY_l2 apply blast
  apply (rule_tac x="(Some U_MissileC)" in exI)
  defer
                      apply (meson CM_MAP_APPLY_PO25)
  using inv_MagId_def l_CM_MAP_APPLY_l2 apply blast
  apply (rule_tac x="(Some U_None)" in exI)
                      defer
                      apply (meson CM_MAP_APPLY_PO25)
  using inv_MagId_def l_CM_MAP_APPLY_l2 apply blast
                      apply (meson MissileType.exhaust)+
  defer
     apply (rule_tac x="(Some U_MissileB)" in exI)
  \<comment> \<open>@LF mostly repeated proof. quite annoying "the" etc.\<close>
	oops

	(*
	\<comment>\<open>VDM proof obligation `CM` is spurious given Isabelle's encoding of `measures`.\<close>

\<comment>\<open>VDM source: CM = ?\<close>
\<comment>\<open>in 'CM' (./src/test/resources/Examples/CMSL/CM.vdmsl) at line 172:1\<close>
theorem CM_RECURSIVE_PO27:
	\<comment>\<open>Implicitly defined type invariant checks for quantified type binds\<close>
	"((\<forall> (missileInputs :: MissileInputs)   (outputSoFar :: Output)   (lastMissile :: (MagId \<rightharpoonup> MissileType option))   (curTime :: VDMNat)  . ((((inv_MissileInputs missileInputs)))  \<and>  (((inv_Output outputSoFar)))  \<and>  (((inv_Map inv_MagId (inv_Option inv_MissileType) lastMissile)))  \<and>  (((inv_VDMNat curTime))) \<longrightarrow> ((\<not> (missileInputs = [])) \<longrightarrow> (
		let
	\<comment>\<open>Implicit pattern context projection for `let-bind definition`\<close>

(dummy0::MissileInput) = (hd missileInputs)
		in
			\<comment>\<open>Implicit pattern context projection for `pattern list`\<close>
	 let curMis = (fst dummy0); angle = (snd dummy0) in
			(if (inv_MissileInput dummy0) then
			(
		let
(magid::MagId) = (Angle2MagId angle)
		in

			(if (inv_MagId magid) then
			(((magid \<notin> (dom lastMissile)) \<or> ((magid \<in> (dom lastMissile)) \<and> (((the(missilePriority curMis))) > ((the(missilePriority ((the((the(lastMissile magid))))))))))) \<longrightarrow> (
		let
(newOutput::Output) = (InterruptPlan curTime  outputSoFar  ((the(responseDB curMis)))  magid)
		;

(magidMaplet::(MagId \<rightharpoonup> MissileType option)) = [magid\<mapsto>curMis]
		in

			(if (inv_Output newOutput)
	 \<and>
	((inv_Map inv_MagId (inv_Option inv_MissileType) magidMaplet)) then
			((measure_CM missileInputs  outputSoFar  lastMissile  curTime) > (measure_CM (tl missileInputs)  newOutput  (lastMissile \<dagger> magidMaplet)  (curTime + stepLength)))
		 else
			undefined
		)
		))
		 else
			undefined
		)
		)
		 else
			undefined
		)
		)))))"

	oops

	*)

\<comment>\<open>VDM source: CM = ?\<close>
\<comment>\<open>in 'CM' (./src/test/resources/Examples/CMSL/CM.vdmsl) at line 192:24\<close>
theorem CM_NON_EMPTY_SEQ_PO28:
	\<comment>\<open>Implicitly defined type invariant checks for quantified type binds\<close>
	"((\<forall> (missileInputs :: MissileInputs)   (outputSoFar :: Output)   (lastMissile :: (MagId \<rightharpoonup> MissileType option))   (curTime :: VDMNat)  . ((((inv_MissileInputs missileInputs)))  \<and>  (((inv_Output outputSoFar)))  \<and>  (((inv_Map inv_MagId (inv_Option inv_MissileType) lastMissile)))  \<and>  (((inv_VDMNat curTime))) \<longrightarrow> ((\<not> (missileInputs = [])) \<longrightarrow> (
		let
	\<comment>\<open>Implicit pattern context projection for `let-bind definition`\<close>

(dummy0::MissileInput) = (hd missileInputs)
		in
			\<comment>\<open>Implicit pattern context projection for `pattern list`\<close>
	 let curMis = (fst dummy0); angle = (snd dummy0) in
			(if (inv_MissileInput dummy0) then
			(
		let
(magid::MagId) = (Angle2MagId angle)
		in

			(if (inv_MagId magid) then
			(((magid \<notin> (dom lastMissile)) \<or> ((magid \<in> (dom lastMissile)) \<and> (((the(missilePriority curMis))) > ((the(missilePriority ((the((the(lastMissile magid))))))))))) \<longrightarrow> (
		let
(newOutput::Output) = (InterruptPlan curTime  outputSoFar  ((the(responseDB curMis)))  magid)
		;

\<comment> \<open>@LF missing Some context :-(\<close>
(magidMaplet::(MagId \<rightharpoonup> MissileType option)) = [magid\<mapsto> Some curMis]
		in

			(if (inv_Output newOutput)
	 \<and>
	((inv_Map inv_MagId (inv_Option inv_MissileType) magidMaplet)) then
			(missileInputs \<noteq> [])
		 else
			undefined
		)
		))
		 else
			undefined
		)
		)
		 else
			undefined
		)
		)))))"
	apply (simp add: Let_def, safe)
  \<comment> \<open>@LF even worse: 392 goals! \<close>
	oops

	(*
	\<comment>\<open>VDM proof obligation `CM` is spurious given Isabelle's encoding of `measures`.\<close>

\<comment>\<open>VDM source: CM = ?\<close>
\<comment>\<open>in 'CM' (./src/test/resources/Examples/CMSL/CM.vdmsl) at line 172:1\<close>
theorem CM_RECURSIVE_PO29:
	\<comment>\<open>Implicitly defined type invariant checks for quantified type binds\<close>
	"((\<forall> (missileInputs :: MissileInputs)   (outputSoFar :: Output)   (lastMissile :: (MagId \<rightharpoonup> MissileType option))   (curTime :: VDMNat)  . ((((inv_MissileInputs missileInputs)))  \<and>  (((inv_Output outputSoFar)))  \<and>  (((inv_Map inv_MagId (inv_Option inv_MissileType) lastMissile)))  \<and>  (((inv_VDMNat curTime))) \<longrightarrow> ((\<not> (missileInputs = [])) \<longrightarrow> (
		let
	\<comment>\<open>Implicit pattern context projection for `let-bind definition`\<close>

(dummy0::MissileInput) = (hd missileInputs)
		in
			\<comment>\<open>Implicit pattern context projection for `pattern list`\<close>
	 let curMis = (fst dummy0); angle = (snd dummy0) in
			(if (inv_MissileInput dummy0) then
			(
		let
(magid::MagId) = (Angle2MagId angle)
		in

			(if (inv_MagId magid) then
			((\<not> ((magid \<notin> (dom lastMissile)) \<or> ((magid \<in> (dom lastMissile)) \<and> (((the(missilePriority curMis))) > ((the(missilePriority ((the((the(lastMissile magid)))))))))))) \<longrightarrow> ((measure_CM missileInputs  outputSoFar  lastMissile  curTime) > (measure_CM (tl missileInputs)  outputSoFar  lastMissile  (curTime + stepLength))))
		 else
			undefined
		)
		)
		 else
			undefined
		)
		)))))"

	oops

	*)

\<comment>\<open>VDM source: CM = ?\<close>
\<comment>\<open>in 'CM' (./src/test/resources/Examples/CMSL/CM.vdmsl) at line 195:21\<close>
theorem CM_NON_EMPTY_SEQ_PO30:
	\<comment>\<open>Implicitly defined type invariant checks for quantified type binds\<close>
	"((\<forall> (missileInputs :: MissileInputs)   (outputSoFar :: Output)   (lastMissile :: (MagId \<rightharpoonup> MissileType option))   (curTime :: VDMNat)  . ((((inv_MissileInputs missileInputs)))  \<and>  (((inv_Output outputSoFar)))  \<and>  (((inv_Map inv_MagId (inv_Option inv_MissileType) lastMissile)))  \<and>  (((inv_VDMNat curTime))) \<longrightarrow> ((\<not> (missileInputs = [])) \<longrightarrow> (
		let
	\<comment>\<open>Implicit pattern context projection for `let-bind definition`\<close>

(dummy0::MissileInput) = (hd missileInputs)
		in
			\<comment>\<open>Implicit pattern context projection for `pattern list`\<close>
	 let curMis = (fst dummy0); angle = (snd dummy0) in
			(if (inv_MissileInput dummy0) then
			(
		let
(magid::MagId) = (Angle2MagId angle)
		in

			(if (inv_MagId magid) then
			((\<not> ((magid \<notin> (dom lastMissile)) \<or> ((magid \<in> (dom lastMissile)) \<and> (((the(missilePriority curMis))) > ((the(missilePriority ((the((the(lastMissile magid)))))))))))) \<longrightarrow> (missileInputs \<noteq> []))
		 else
			undefined
		)
		)
		 else
			undefined
		)
		)))))"
	using CM_MAP_APPLY_PO25 by presburger

\<comment>\<open>Processing VDM exports as Isabelle hidden declarations\<close>

\<comment> \<open>@LF 13 sledgehammered, 3 simplified expansion, 4 oopsed (recursive), 6 nitpicked, 4 manual needing 6 extra lemmas\<close>
end


chapter \<open>Instantiation for \<open>\<lambda>\<close>-free terms according to Blanchette\<close>

theory Lambda_Free_Compat
imports Unification_Compat "Lambda_Free_RPOs.Lambda_Free_Term"
begin

text \<open>
  Another instantiation of the algebra for Blanchette et al.'s term type
  \<^cite>\<open>blanchette2016lambda\<close>.
\<close>

hide_const (open) Lambda_Free_Term.subst

instantiation tm :: (is_name, is_name) "pre_term" begin

definition app_tm where
"app_tm = tm.App"

definition unapp_tm where
"unapp_tm t = (case t of App t u \<Rightarrow> Some (t, u) | _ \<Rightarrow> None)"

definition const_tm where
"const_tm n = Hd (Sym (of_name n))"

definition unconst_tm where
"unconst_tm t = (case t of Hd (Sym a) \<Rightarrow> Some (to_name a) | _ \<Rightarrow> None)"

definition free_tm where
"free_tm n = Hd (Var (of_name n))"

definition unfree_tm where
"unfree_tm t = (case t of Hd (Var a) \<Rightarrow> Some (to_name a) | _ \<Rightarrow> None)"

context
  includes fset.lifting
begin

lift_definition frees_tm :: "('a, 'b) tm \<Rightarrow> name fset" is "\<lambda>t. to_name ` vars t"
  by auto

lift_definition consts_tm :: "('a, 'b) tm \<Rightarrow> name fset" is "\<lambda>t. to_name ` syms t"
  by auto

end

lemma frees_tm[code, simp]:
  "frees (App f x) = frees f |\<union>| frees x"
  "frees (Hd h) = (case h of Sym _ \<Rightarrow> fempty | Var v \<Rightarrow> {| to_name v |})"
including fset.lifting
by (transfer; auto split: hd.splits)+

lemma consts_tm[code, simp]:
  "consts (App f x) = consts f |\<union>| consts x"
  "consts (Hd h) = (case h of Var _ \<Rightarrow> fempty | Sym v \<Rightarrow> {| to_name v |})"
including fset.lifting
by (transfer; auto split: hd.splits)+

definition subst_tm :: "('a, 'b) tm \<Rightarrow> (name, ('a, 'b) tm) fmap \<Rightarrow> ('a, 'b) tm" where
"subst_tm t env =
  Lambda_Free_Term.subst (fmlookup_default env (Hd \<circ> Var \<circ> of_name) \<circ> to_name) t"

lemma subst_tm[code, simp]:
  "subst (App t u) env = App (subst t env) (subst u env)"
  "subst (Hd h) env = (case h of
    Sym s \<Rightarrow> Hd (Sym s) |
    Var x \<Rightarrow> (case fmlookup env (to_name x) of
      Some t' \<Rightarrow> t'
    | None \<Rightarrow> Hd (Var x)))"
unfolding subst_tm_def
by (auto simp: fmlookup_default_def split: hd.splits option.splits)

instance
by standard
   (auto
      simp: app_tm_def unapp_tm_def const_tm_def unconst_tm_def free_tm_def unfree_tm_def of_name_inj
      split: tm.splits hd.splits option.splits)

end

instantiation tm :: (is_name, is_name) "term" begin

definition abs_pred_tm :: "(('a, 'b) tm \<Rightarrow> bool) \<Rightarrow> ('a, 'b) tm \<Rightarrow> bool" where
"abs_pred_tm P t \<longleftrightarrow> True"

instance proof (standard, goal_cases)
  case (1 P t)
  then show ?case
    proof (induction t)
      case (Hd h)
      then show ?case
        apply (cases h)
        apply (auto simp: free_tm_def const_tm_def)
        apply (metis of_to_name)+
        done
    qed (auto simp: app_tm_def)
qed (auto simp: abs_pred_tm_def)

end

lemma apps_list_comb: "apps f xs = list_comb f xs"
by (induction xs arbitrary: f) (auto simp: app_tm_def)

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 Shift_Left_Hoare
  imports VHDL_Hoare_Complete Bits_Int_Aux
begin

datatype sig = IN | OUT

definition shiftl :: "nat \<Rightarrow> sig conc_stmt" where
  "shiftl n \<equiv> process {IN} : Bassign_trans OUT (Bshiftl (Bsig IN) n) 1"

lemma potential_tyenv:
  assumes "seq_wt \<Gamma> (Bassign_trans OUT (Bshiftl (Bsig IN) n) 1)"
  shows "\<exists>len>0. \<Gamma> IN = Lty Uns len \<and> \<Gamma> OUT = Lty Uns len \<or> \<Gamma> IN = Lty Sig len \<and> \<Gamma> OUT = Lty Sig len"
  apply (rule seq_wt_cases(4)[OF assms])
  by (metis bexp_wt_cases_shiftl bexp_wt_cases_slice(2))

locale unsigned_shift_left =
  fixes \<Gamma> :: "sig tyenv"
  fixes len :: nat
  fixes amount :: nat
  assumes "0 < len"
  assumes "\<Gamma> IN = Lty Uns len \<and> \<Gamma> OUT = Lty Uns len \<or>
           \<Gamma> IN = Lty Sig len \<and> \<Gamma> OUT = Lty Sig len"
begin

lemma well_typed:
  "seq_wt \<Gamma> (Bassign_trans OUT (Bshiftl (Bsig IN) n) 1)"
  by (rule seq_wt.intros(4))
     (smt bexp_wt.intros(21) bexp_wt.intros(22) bexp_wt.intros(3) unsigned_shift_left_axioms
     unsigned_shift_left_def)

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

text \<open>Here we factor out common expression in both inv1 and inv2. It is parametrised by the index
we are interested with for C (first argument) and A (the second argument). Note that the index
we are interested with for A should be the same as the index for B.\<close>

definition property :: "nat \<Rightarrow> nat \<Rightarrow> sig assn2" where
  "property idxc idx =
      (\<lambda>tw. lof_wline tw OUT idxc = drop amount (lof_wline tw IN idx @ replicate amount False))"

definition inv :: "sig assn2" where
  "inv tw \<equiv> (\<forall>i < fst tw. property (i + 1) i tw)"

definition inv2 :: "sig assn2" where
  "inv2 tw \<equiv> (disjnt {IN} (event_of tw) \<longrightarrow> (\<forall>i \<ge> fst tw. property (i + 1) (fst tw) tw))"

abbreviation "next_world tw \<equiv> (next_time_world tw, snd tw)"

lemma inv_next_time_uns:
  assumes "inv tw"
  assumes "beval_world_raw2 tw (Bshiftl (Bsig IN) amount) v" and "type_of v = Lty Uns len"
  defines "tw' \<equiv> tw[OUT, 1 :=\<^sub>2 v]"
  shows   "inv (next_time_world tw', snd tw')"
  unfolding inv_def
proof (rule, rule)
  fix i
  assume "i < fst (next_world tw')"
  hence "i < next_time_world tw'"
    by auto
  have "fst tw' < next_time_world tw'"
    using next_time_world_at_least  using nat_less_le by blast
  moreover have "fst tw = fst tw'"
    unfolding tw'_def worldline_upd2_def worldline_upd_def by auto
  ultimately have "fst tw < next_time_world tw'"
    by auto
  hence "i < fst tw \<or> fst tw \<le> i \<and> i < next_time_world tw' - 1 \<or> i = next_time_world tw' - 1"
    using \<open>i < next_time_world tw'\<close> by linarith
  moreover
  { assume "i < fst tw"
    have "lof_wline tw' OUT (i + 1) = lof_wline tw OUT (i + 1)"
      by (metis \<open>i < get_time tw\<close> add_mono1 tw'_def worldline_upd2_before_dly)
    also have "... = drop amount (lof_wline tw IN i @ replicate amount False)"
      using assms(1) \<open>i < fst tw\<close> unfolding inv_def property_def by auto
    also have "... = drop amount (lof_wline tw' IN i @ replicate amount False)"
      by (metis \<open>i < get_time tw\<close> add.commute trans_less_add2 tw'_def worldline_upd2_before_dly)
    finally have "property (i + 1) i (next_time_world tw', snd tw')"
      unfolding property_def by auto }
  moreover
  { assume "fst tw \<le> i \<and> i < next_time_world tw' - 1"
    hence "fst tw \<le> i" and "i < next_time_world tw' - 1"
      by auto
    hence "lof_wline tw' OUT (i + 1) = lof_wline tw' OUT (fst tw + 1)"
      using unchanged_until_next_time_world
      by (metis (mono_tags, lifting) Suc_eq_plus1 \<open>get_time tw = get_time tw'\<close> le_Suc_eq le_add1
          le_less_trans less_diff_conv)
    moreover have "lof_wline tw' IN i = lof_wline tw' IN (fst tw)"
      using unchanged_until_next_time_world
      by (metis \<open>get_time tw = get_time tw'\<close> \<open>get_time tw \<le> i\<close> \<open>i < next_time_world tw'\<close> worldline_upd2_before_dly)
    moreover have "property (fst tw + 1) (fst tw) tw'"
    proof -
      have assm2: "beval_world_raw (snd tw) (fst tw) (Bshiftl (Bsig IN) amount) v"
        using assms(2) unfolding beval_world_raw2_def by auto
      have "wline_of tw' OUT (fst tw + 1) = v"
        unfolding tw'_def worldline_upd2_def worldline_upd_def by auto
      also have "... =  Lv Uns (drop amount (lof_wline tw IN (fst tw) @ replicate amount False))"
        apply (rule beval_world_raw_cases[OF assm2])
        apply ( erule beval_cases)+
        unfolding state_of_world_def
        apply (metis comp_apply drop_append drop_replicate val.sel(3))
        using assms(3) by auto
      also have "... =  Lv Uns (drop amount (lof_wline tw' IN (fst tw) @ replicate amount False))"
        by (metis less_add_one tw'_def worldline_upd2_before_dly)
      finally show ?thesis
        unfolding property_def bin_to_bl_def by auto
    qed
    ultimately have "property (i + 1) i (next_world tw')"
      unfolding property_def by auto }
  moreover
  { assume "i = next_time_world tw' - 1"
    hence "lof_wline tw' OUT (i + 1) = lof_wline tw' OUT (next_time_world tw')"
      using \<open>i < next_time_world tw'\<close> by force
    also have "... = lof_wline tw' OUT (fst tw + 1)"
      using \<open>fst tw < next_time_world tw'\<close> unfolding tw'_def worldline_upd2_def
      worldline_upd_def by auto
    finally have "lof_wline tw' OUT (i + 1) = lof_wline tw' OUT (fst tw + 1)"
      by auto
    moreover have "property (fst tw + 1) (fst tw) tw'"
    proof -
      have assm2: "beval_world_raw (snd tw) (fst tw) (Bshiftl (Bsig IN) amount) v"
        using assms(2) unfolding beval_world_raw2_def by auto
      have "wline_of tw' OUT (fst tw + 1) = v"
        unfolding tw'_def worldline_upd2_def worldline_upd_def by auto
      also have "... =  Lv Uns (drop amount (lof_wline tw IN (fst tw) @ replicate amount False))"
        apply (rule beval_world_raw_cases[OF assm2])
        apply ( erule beval_cases)+
        unfolding state_of_world_def
        apply (metis comp_apply drop_append drop_replicate val.sel(3))
        using assms(3) by auto
      also have "... =  Lv Uns (drop amount (lof_wline tw' IN (fst tw) @ replicate amount False))"
        by (metis less_add_one tw'_def worldline_upd2_before_dly)
      finally show ?thesis
        unfolding property_def bin_to_bl_def by auto
    qed
    moreover have "lof_wline tw' IN i = lof_wline tw' IN (fst tw)"
      using unchanged_until_next_time_world
      by (metis \<open>get_time tw < next_time_world tw'\<close> \<open>get_time tw = get_time tw'\<close> \<open>i <
      next_time_world tw'\<close> \<open>i = next_time_world tw' - 1\<close> add_le_imp_le_diff discrete)+
    ultimately have "property (i + 1) i (next_world tw')"
      unfolding property_def by auto }
  ultimately show "property (i + 1) i (next_world tw')"
    by auto
qed

lemma inv_next_time_sig:
  assumes "inv tw"
  assumes "beval_world_raw2 tw (Bshiftl (Bsig IN) amount) v" and "type_of v = Lty Sig len"
  defines "tw' \<equiv> tw[OUT, 1 :=\<^sub>2 v]"
  shows   "inv (next_time_world tw', snd tw')"
  unfolding inv_def
proof (rule, rule)
  fix i
  assume "i < fst (next_world tw')"
  hence "i < next_time_world tw'"
    by auto
  have "fst tw' < next_time_world tw'"
    using next_time_world_at_least  using nat_less_le by blast
  moreover have "fst tw = fst tw'"
    unfolding tw'_def worldline_upd2_def worldline_upd_def by auto
  ultimately have "fst tw < next_time_world tw'"
    by auto
  hence "i < fst tw \<or> fst tw \<le> i \<and> i < next_time_world tw' - 1 \<or> i = next_time_world tw' - 1"
    using \<open>i < next_time_world tw'\<close> by linarith
  moreover
  { assume "i < fst tw"
    have "lof_wline tw' OUT (i + 1) = lof_wline tw OUT (i + 1)"
      by (metis \<open>i < get_time tw\<close> add_mono1 tw'_def worldline_upd2_before_dly)
    also have "... = drop amount (lof_wline tw IN i @ replicate amount False)"
      using assms(1) \<open>i < fst tw\<close> unfolding inv_def property_def by auto
    also have "... = drop amount (lof_wline tw' IN i @ replicate amount False)"
      by (metis \<open>i < get_time tw\<close> add.commute trans_less_add2 tw'_def worldline_upd2_before_dly)
    finally have "property (i + 1) i (next_time_world tw', snd tw')"
      unfolding property_def by auto }
  moreover
  { assume "fst tw \<le> i \<and> i < next_time_world tw' - 1"
    hence "fst tw \<le> i" and "i < next_time_world tw' - 1"
      by auto
    hence "lof_wline tw' OUT (i + 1) = lof_wline tw' OUT (fst tw + 1)"
      using unchanged_until_next_time_world
      by (metis (mono_tags, lifting) Suc_eq_plus1 \<open>get_time tw = get_time tw'\<close> le_Suc_eq le_add1
          le_less_trans less_diff_conv)
    moreover have "lof_wline tw' IN i = lof_wline tw' IN (fst tw)"
      using unchanged_until_next_time_world
      by (metis \<open>get_time tw = get_time tw'\<close> \<open>get_time tw \<le> i\<close> \<open>i < next_time_world tw'\<close> worldline_upd2_before_dly)
    moreover have "property (fst tw + 1) (fst tw) tw'"
    proof -
      have assm2: "beval_world_raw (snd tw) (fst tw) (Bshiftl (Bsig IN) amount) v"
        using assms(2) unfolding beval_world_raw2_def by auto
      have "wline_of tw' OUT (fst tw + 1) = v"
        unfolding tw'_def worldline_upd2_def worldline_upd_def by auto
      also have "... =  Lv Sig (drop amount (lof_wline tw IN (fst tw) @ replicate amount False))"
        apply (rule beval_world_raw_cases[OF assm2])
        apply ( erule_tac[!] beval_cases)+
         prefer 2
        unfolding state_of_world_def
        apply (metis comp_apply drop_append drop_replicate val.sel(3))
        using assms(3) by auto
      also have "... =  Lv Sig (drop amount (lof_wline tw' IN (fst tw) @ replicate amount False))"
        by (metis less_add_one tw'_def worldline_upd2_before_dly)
      finally show ?thesis
        unfolding property_def bin_to_bl_def by auto
    qed
    ultimately have "property (i + 1) i (next_world tw')"
      unfolding property_def by auto }
  moreover
  { assume "i = next_time_world tw' - 1"
    hence "lof_wline tw' OUT (i + 1) = lof_wline tw' OUT (next_time_world tw')"
      using \<open>i < next_time_world tw'\<close> by force
    also have "... = lof_wline tw' OUT (fst tw + 1)"
      using \<open>fst tw < next_time_world tw'\<close> unfolding tw'_def worldline_upd2_def
      worldline_upd_def by auto
    finally have "lof_wline tw' OUT (i + 1) = lof_wline tw' OUT (fst tw + 1)"
      by auto
    moreover have "property (fst tw + 1) (fst tw) tw'"
    proof -
      have assm2: "beval_world_raw (snd tw) (fst tw) (Bshiftl (Bsig IN) amount) v"
        using assms(2) unfolding beval_world_raw2_def by auto
      have "wline_of tw' OUT (fst tw + 1) = v"
        unfolding tw'_def worldline_upd2_def worldline_upd_def by auto
      also have "... =  Lv Sig (drop amount (lof_wline tw IN (fst tw) @ replicate amount False))"
        apply (rule beval_world_raw_cases[OF assm2])
        apply ( erule_tac[!] beval_cases)+
        prefer 2
        unfolding state_of_world_def
        apply (metis comp_apply drop_append drop_replicate val.sel(3))
        using assms(3) by auto
      also have "... =  Lv Sig (drop amount (lof_wline tw' IN (fst tw) @ replicate amount False))"
        by (metis less_add_one tw'_def worldline_upd2_before_dly)
      finally show ?thesis
        unfolding property_def bin_to_bl_def by auto
    qed
    moreover have "lof_wline tw' IN i = lof_wline tw' IN (fst tw)"
      using unchanged_until_next_time_world
      by (metis \<open>get_time tw < next_time_world tw'\<close> \<open>get_time tw = get_time tw'\<close> \<open>i <
      next_time_world tw'\<close> \<open>i = next_time_world tw' - 1\<close> add_le_imp_le_diff discrete)+
    ultimately have "property (i + 1) i (next_world tw')"
      unfolding property_def by auto }
  ultimately show "property (i + 1) i (next_world tw')"
    by auto
qed

lemma type_correctness_length:
  assumes "wityping \<Gamma> (snd tw)"
  assumes "beval_world_raw2 tw (Bshiftl (Bsig IN) amount) v"
  shows   "type_of v = Lty Uns len \<or> type_of v = Lty Sig len"
proof -
  have "beval_world_raw (snd tw) (fst tw) (Bshiftl (Bsig IN) amount) v"
    using assms(2) unfolding beval_world_raw2_def by auto
  have *: "type_of (state_of_world (snd tw) (fst tw) IN) = Lty Uns len
       \<or> type_of (state_of_world (snd tw) (fst tw) IN) = Lty Sig len"
    using assms(1) unfolding wityping_def
    by (metis (full_types) state_of_world_def unsigned_shift_left_axioms unsigned_shift_left_def wtyping_def)
  show ?thesis
    apply (rule beval_world_raw_cases[OF \<open>beval_world_raw (snd tw) (fst tw) (Bshiftl (Bsig IN) amount) v\<close>])
    apply (erule beval_cases)+
    apply (metis *
        add.left_neutral add_diff_cancel_left' diff_is_0_eq' le_add_diff_inverse2 length_append
        length_drop length_replicate nat_le_linear rev_min_pm1 type_of.simps(2))
    apply (erule beval_cases)+
    apply (metis "*" add_left_imp_eq diff_le_self le_add_diff_inverse length_append length_drop
        length_replicate min_pm1 rev_min_pm1 type_of.simps(2))
    done
qed

lemma seq_hoare_next_time:
  "\<turnstile> [\<lambda>tw. inv tw \<and> wityping \<Gamma> (snd tw)]
        Bassign_trans OUT (Bshiftl (Bsig IN) amount) 1
     [\<lambda>tw. inv (next_world tw)]"
  apply (rule Conseq2[where Q="\<lambda>tw. inv (next_world tw) \<and> wityping \<Gamma> (snd tw)", rotated 1], rule Assign2, simp)
  using inv_next_time_sig inv_next_time_uns type_correctness_length
  by (metis BassignE_hoare2 seq_stmt_preserve_wityping_hoare well_typed)

lemma seq_hoare_next_time_post:
  "\<turnstile> [\<lambda>tw. inv tw \<and> wityping \<Gamma> (snd tw)]
        Bassign_trans OUT (Bshiftl (Bsig IN) amount) 1
     [\<lambda>tw. \<forall>j \<in> {fst tw <.. next_time_world tw}. inv (j, snd tw)]"
  apply (rule Conseq2[rotated])
    apply (rule seq_hoare_next_time)
  unfolding inv_def property_def by auto

lemma seq_hoare_next_time0:
  "\<turnstile> [\<lambda>tw. fst tw = 0 \<and> wityping \<Gamma> (snd tw)]
        Bassign_trans OUT (Bshiftl (Bsig IN) amount) 1
     [\<lambda>tw. inv (next_world tw)]"
  apply (rule Conseq2[where Q="\<lambda>tw. inv (next_world tw) \<and> wityping \<Gamma> (snd tw)", rotated 1], rule Assign2, simp)
  using inv_next_time_sig inv_next_time_uns type_correctness_length unfolding inv_def
  by (metis BassignE_hoare2 gr_implies_not_zero seq_stmt_preserve_wityping_hoare well_typed)

lemma conc_hoare:
  "\<And>tw. inv tw \<and> inv2 tw \<and> disjnt {IN} (event_of tw) \<Longrightarrow> inv (next_world tw)"
proof -
  fix tw
  assume "inv tw \<and> inv2 tw \<and> disjnt {IN} (event_of tw)"
  hence "inv tw" and "inv2 tw" and "disjnt {IN} (event_of tw)"
    by auto
  { fix i
    assume "i < next_time_world tw"
    have "fst tw < next_time_world tw"
      by (simp add: next_time_world_at_least)
    have "i < fst tw \<or> fst tw \<le> i"
      by auto
    moreover
    { assume "i < fst tw"
      hence "property (i + 1) i tw"
        using \<open>inv tw\<close> unfolding inv_def by auto
      hence "property (i + 1) i (next_world tw)"
        unfolding property_def by simp }
    moreover
    { assume "fst tw \<le> i"
      moreover have "\<forall>i \<ge> fst tw. property (i + 1) (fst tw) tw"
        using \<open>inv2 tw\<close> \<open>disjnt {IN} (event_of tw)\<close> unfolding inv2_def
        by auto
      ultimately have "property (i + 1) (fst tw) tw"
        by auto
      hence "property (i + 1) i tw"
        unfolding property_def
        by (metis \<open>get_time tw \<le> i\<close> \<open>i < next_time_world tw\<close> unchanged_until_next_time_world)
      hence "property (i + 1) i (next_world tw)"
        unfolding property_def by auto }
    ultimately have "property (i + 1) i (next_world tw)"
      by auto }
  thus "inv (next_world tw)"
    unfolding inv_def by auto
qed

lemma aux:
  "\<And>tw. inv (next_world tw) \<Longrightarrow> \<forall>j \<in> {fst tw <.. next_time_world tw}. inv (j, snd tw)"
  unfolding inv_def
  by (smt comp_apply fst_conv greaterThanAtMost_iff le_Suc_ex property_def snd_conv trans_less_add1)

lemma conc_hoare2:
  "\<And>tw. inv tw \<and> inv2 tw \<and> disjnt {IN} (event_of tw) \<Longrightarrow> \<forall>j \<in> {fst tw <.. next_time_world tw}. inv2 (j, snd tw)"
proof (rule)
  fix tw :: "nat \<times> (sig \<Rightarrow> val) \<times> (sig \<Rightarrow> nat \<Rightarrow> val)"
  fix j
  assume "j \<in> {fst tw <.. next_time_world tw}"
  assume "inv tw \<and> inv2 tw \<and> disjnt {IN} (event_of tw)"
  hence "inv tw" and "inv2 tw" and "disjnt {IN} (event_of tw)"
    by auto
  { assume "disjnt {IN} (event_of (j, snd tw))"
    hence *: "lof_wline tw IN j = lof_wline tw IN (j - 1)"
      unfolding event_of_alt_def
      by (smt comp_apply diff_0_eq_0 disjnt_insert1 fst_conv mem_Collect_eq snd_conv)
    have "fst tw < j"
      using \<open>j \<in> {get_time tw<..next_time_world tw}\<close> greaterThanAtMost_iff by blast
    { fix i
      assume "j \<le> i"
      have "property (i + 1) (fst tw) tw"
        using \<open>inv2 tw\<close> \<open>disjnt {IN} (event_of tw)\<close> unfolding inv2_def
        using \<open>fst tw < j\<close> \<open>j \<le> i\<close> by auto
      moreover have "lof_wline tw IN (fst tw) = lof_wline tw IN (j - 1)"
        by (metis (no_types, lifting) \<open>j \<in> {get_time tw<..next_time_world tw}\<close> add_le_imp_le_diff
        diff_is_0_eq' diff_zero discrete dual_order.strict_trans greaterThanAtMost_iff
        le_add_diff_inverse2 le_numeral_extra(4) not_less_iff_gr_or_eq
        unchanged_until_next_time_world zero_less_diff)
      ultimately have "property (i + 1) j (j, snd tw)"
        unfolding property_def using *  by auto }
    hence "\<forall>i\<ge>j. property (i + 1) j (j, snd tw)"
      by auto }
  thus "inv2 (j, snd tw)"
    unfolding inv2_def by auto
qed

lemma inv2_next_time_uns:
  fixes tw
  assumes "beval_world_raw2 tw (Bshiftl (Bsig IN) amount) v" and "type_of v = Lty Uns len"
  defines "tw' \<equiv> tw[OUT, 1 :=\<^sub>2 v]"
  shows   "\<forall>j \<in> {fst tw' <.. next_time_world tw'}. inv2 (j, snd tw')"
  unfolding inv2_def
proof (rule, rule, rule, rule)
  fix i j
  assume "j \<in> {fst tw' <.. next_time_world tw'}"
  assume "disjnt {IN} (event_of (j, snd tw'))"
  hence "IN \<notin> event_of (j, snd tw')"
    by auto
  assume "fst (j, snd tw') \<le> i"
  hence "j \<le> i"
    by auto
  have "fst tw' < j"
    using next_time_world_at_least \<open>j \<in> {get_time tw'<..next_time_world tw'}\<close> greaterThanAtMost_iff
    by blast
  moreover have "fst tw = fst tw'"
    unfolding tw'_def unfolding worldline_upd2_def by auto
  ultimately have "fst tw < j"
    by auto
  have 0: "wline_of (next_world tw') IN j = wline_of tw IN (fst tw)"
  proof -
    have "wline_of tw' IN j = wline_of tw' IN (j - 1)"
      using \<open>IN \<notin> event_of (j, snd tw')\<close> unfolding event_of_alt_def
      using \<open>get_time tw' < j\<close> by auto
    also have " ... = wline_of tw' IN (fst tw')"
      using unchanged_until_next_time_world
      by (metis (no_types, lifting) One_nat_def \<open>j \<in> {get_time tw'<..next_time_world tw'}\<close> discrete
      gr_implies_not_zero greaterThanAtMost_iff le_0_eq le_add_diff_inverse2 less_Suc_eq_le
      not_less)
    also have "... = wline_of tw' IN (fst tw)"
      by (simp add: \<open>get_time tw = get_time tw'\<close>)
    also have "... = wline_of tw IN (fst tw)"
      unfolding tw'_def worldline_upd2_def worldline_upd_def by auto
    finally show "wline_of (next_world tw') IN j = wline_of tw IN (fst tw)"
      by auto
  qed
  have assm2: "beval_world_raw (snd tw) (fst tw) (Bshiftl (Bsig IN) amount) v"
    using assms(1) unfolding beval_world_raw2_def by auto
  have "wline_of (next_world tw') OUT (i + 1) = v"
  proof -
    have "wline_of tw' OUT (i + 1) = v"
      using `fst tw < j` \<open>j \<le> i\<close>
      unfolding tw'_def worldline_upd2_def worldline_upd_def by auto
    thus ?thesis
      by auto
  qed
  also have "lval_of ... = drop amount (lof_wline tw IN (fst tw) @ replicate amount False)"
    apply (rule beval_world_raw_cases[OF assm2])
    apply (erule beval_cases)+
    apply (metis comp_def drop_append drop_replicate state_of_world_def val.sel(3))
    using assms(2) by auto
  finally have "property (i + 1) j (j, snd tw')"
    unfolding property_def using 0  by auto
  thus "property (i + 1) (get_time (j, snd tw')) (j, snd tw')"
    by auto
qed

lemma inv2_next_time_sig:
  fixes tw
  assumes "beval_world_raw2 tw (Bshiftl (Bsig IN) amount) v" and "type_of v = Lty Sig len"
  defines "tw' \<equiv> tw[OUT, 1 :=\<^sub>2 v]"
  shows   "\<forall>j \<in> {fst tw' <.. next_time_world tw'}. inv2 (j, snd tw')"
  unfolding inv2_def
proof (rule, rule, rule, rule)
  fix i j
  assume "j \<in> {fst tw' <.. next_time_world tw'}"
  assume "disjnt {IN} (event_of (j, snd tw'))"
  hence "IN \<notin> event_of (j, snd tw')"
    by auto
  assume "fst (j, snd tw') \<le> i"
  hence "j \<le> i"
    by auto
  have "fst tw' < j"
    using next_time_world_at_least \<open>j \<in> {get_time tw'<..next_time_world tw'}\<close> greaterThanAtMost_iff
    by blast
  moreover have "fst tw = fst tw'"
    unfolding tw'_def unfolding worldline_upd2_def by auto
  ultimately have "fst tw < j"
    by auto
  have 0: "wline_of (next_world tw') IN j = wline_of tw IN (fst tw)"
  proof -
    have "wline_of tw' IN j = wline_of tw' IN (j - 1)"
      using \<open>IN \<notin> event_of (j, snd tw')\<close> unfolding event_of_alt_def
      using \<open>get_time tw' < j\<close> by auto
    also have " ... = wline_of tw' IN (fst tw')"
      using unchanged_until_next_time_world
      by (metis (no_types, lifting) One_nat_def \<open>j \<in> {get_time tw'<..next_time_world tw'}\<close> discrete
      gr_implies_not_zero greaterThanAtMost_iff le_0_eq le_add_diff_inverse2 less_Suc_eq_le
      not_less)
    also have "... = wline_of tw' IN (fst tw)"
      by (simp add: \<open>get_time tw = get_time tw'\<close>)
    also have "... = wline_of tw IN (fst tw)"
      unfolding tw'_def worldline_upd2_def worldline_upd_def by auto
    finally show "wline_of (next_world tw') IN j = wline_of tw IN (fst tw)"
      by auto
  qed
  have assm2: "beval_world_raw (snd tw) (fst tw) (Bshiftl (Bsig IN) amount) v"
    using assms(1) unfolding beval_world_raw2_def by auto
  have "wline_of (next_world tw') OUT (i + 1) = v"
  proof -
    have "wline_of tw' OUT (i + 1) = v"
      using `fst tw < j` \<open>j \<le> i\<close>
      unfolding tw'_def worldline_upd2_def worldline_upd_def by auto
    thus ?thesis
      by auto
  qed
  also have "lval_of ... = drop amount (lof_wline tw IN (fst tw) @ replicate amount False)"
    apply (rule beval_world_raw_cases[OF assm2])
    apply (erule_tac[!] beval_cases)+
    apply (metis comp_def drop_append drop_replicate state_of_world_def val.sel(3))
    by (metis comp_def drop_append drop_replicate state_of_world_def val.sel(3))
  finally have "property (i + 1) j (j, snd tw')"
    unfolding property_def using 0  by auto
  thus "property (i + 1) (get_time (j, snd tw')) (j, snd tw')"
    by auto
qed

lemma seq_hoare_next_time1:
  shows "\<turnstile> [\<lambda>tw. wityping \<Gamma> (snd tw)]
              Bassign_trans OUT (Bshiftl (Bsig IN) amount) 1
           [\<lambda>tw. \<forall>j \<in> {fst tw <.. next_time_world tw}. inv2 (j, snd tw)]"
  apply (rule Assign2_altI)
  using inv2_next_time_sig inv2_next_time_uns type_correctness_length
  by blast

lemma conc_hoare3:
  "\<turnstile> \<lbrace>\<lambda>tw. (inv tw \<and> inv2 tw) \<and> wityping \<Gamma> (snd tw)\<rbrace>
        shiftl amount
     \<lbrace>\<lambda>tw. \<forall>j \<in> {fst tw <.. next_time_world tw}. inv (j, snd tw) \<and> inv2 (j, snd tw)\<rbrace>"
  unfolding shiftl_def
  apply (rule Single)
   apply (rule Conj_univ_qtfd)
    apply (rule Conseq2[rotated])
      apply (rule seq_hoare_next_time_post)
     apply simp
    apply simp
   apply (rule Conseq2[rotated])
     apply (rule seq_hoare_next_time1)
    apply simp
   apply simp
  using conc_hoare conc_hoare2 aux by blast

lemma seq_wt_sub:
  "seq_wt \<Gamma> (Bassign_trans OUT (Bshiftl (Bsig IN) amount) 1)"
  using well_typed by blast

lemma conc_hoare4:
  "\<turnstile> \<lbrace>\<lambda>tw. (inv tw \<and> inv2 tw) \<and> wityping \<Gamma> (snd tw)\<rbrace>
          shiftl amount
     \<lbrace>\<lambda>tw. \<forall>i\<in>{get_time tw<..next_time_world tw}. (local.inv (i, snd tw) \<and> inv2 (i, snd tw)) \<and> wityping \<Gamma> (snd tw)\<rbrace>"
  apply (rule Conj2_univ_qtfd[where R="\<lambda>tw. wityping \<Gamma> (snd tw)", unfolded snd_conv])
   apply (rule Conseq'[rotated])
     apply (rule conc_hoare3)
    apply simp
   apply simp
  apply (rule Conseq'[rotated])
    apply (unfold shiftl_def, rule single_conc_stmt_preserve_wityping_hoare)
    apply (rule seq_wt_sub)
  by auto

lemma conc_sim':
  "\<turnstile>\<^sub>s \<lbrace>\<lambda>tw. (inv tw \<and> inv2 tw) \<and> wityping \<Gamma> (snd tw)\<rbrace> shiftl amount \<lbrace>\<lambda>tw. (inv tw \<and> inv2 tw) \<and> wityping \<Gamma> (snd tw)\<rbrace>"
  apply (rule While)
  apply (unfold snd_conv, rule conc_hoare4)
  done

lemma conc_sim2:
  "\<turnstile>\<^sub>s \<lbrace>\<lambda>tw. (inv tw \<and> inv2 tw) \<and> wityping \<Gamma> (snd tw)\<rbrace> shiftl amount \<lbrace>inv\<rbrace>"
  using conc_sim' Conseq_sim by blast

lemma init_sat_inv:
  "init_sim_hoare (\<lambda>tw. fst tw = 0 \<and> wityping \<Gamma> (snd tw)) (shiftl amount) (\<lambda>tw. inv tw \<and> wityping \<Gamma> (snd tw))"
  unfolding shiftl_def
  apply (rule AssignI)
  apply (rule SingleI)
  apply (rule Conj)
  unfolding snd_conv apply(rule seq_hoare_next_time0)
  apply (rule strengthen_precondition2)
  by (metis seq_stmt_preserve_wityping_hoare well_typed)

lemma init_sat_inv2:
  "init_sim_hoare (\<lambda>tw. wityping \<Gamma> (snd tw)) (shiftl amount) inv2"
  unfolding shiftl_def
  apply (rule AssignI)
  apply (rule SingleI)
  apply (rule Conseq2[rotated])
  unfolding snd_conv apply (rule seq_hoare_next_time1)
  apply (simp add: next_time_world_at_least)
  by auto

lemma init_sat_inv_comb:
  shows "init_sim_hoare (\<lambda>tw. fst tw = 0 \<and> wityping \<Gamma> (snd tw)) (shiftl amount)  (\<lambda>tw. (inv tw \<and> wityping \<Gamma> (snd tw)) \<and> inv2 tw)"
  apply (rule ConjI_sim)
  apply (rule init_sat_inv)
  apply (rule ConseqI_sim[rotated])
  apply (rule init_sat_inv2)
  by blast+

lemma correctness:
  assumes "sim_fin w (i + 1) (shiftl amount) tw'" and "wityping \<Gamma> w"
  shows   "property (i + 1) i tw'"
proof -
  obtain tw where "init_sim (0, w) (shiftl amount) tw" and  "tw, i + 1, shiftl amount \<Rightarrow>\<^sub>S tw'"
    using premises_sim_fin_obt[OF assms(1)] by auto
  hence "i + 1 = fst tw'"
    using world_maxtime_lt_fst_tres  by blast
  have "conc_stmt_wf (shiftl amount)"
    unfolding conc_stmt_wf_def shiftl_def by auto
  moreover have "nonneg_delay_conc (shiftl amount)"
    unfolding shiftl_def by auto
  ultimately have "init_sim_valid (\<lambda>tw. fst tw = 0 \<and> wityping \<Gamma> (snd tw)) (shiftl amount) (\<lambda>tw. (inv tw \<and> wityping \<Gamma> (snd tw)) \<and> inv2 tw)"
    using init_sim_hoare_soundness[OF init_sat_inv_comb]
    by (metis (no_types, lifting) conc_wt_cases(1) init_sat_inv_comb
    init_sim_hoare_soundness sub_def strengthen_precondition_init_sim_hoare)
  hence "inv tw \<and> wityping \<Gamma> (snd tw) \<and> inv2 tw"
    using \<open>init_sim (0, w) (shiftl amount) tw\<close> fst_conv assms(2) unfolding init_sim_valid_def
    by (metis snd_conv)
  hence "inv tw" and "inv2 tw" and "wityping \<Gamma> (snd tw)"
    by auto
  moreover have "\<Turnstile>\<^sub>s \<lbrace>\<lambda>tw. (local.inv tw \<and> inv2 tw) \<and> wityping \<Gamma> (snd tw)\<rbrace> Shift_Left_Hoare.shiftl amount \<lbrace>local.inv\<rbrace>"
    using conc_sim_soundness[OF conc_sim2] \<open>conc_stmt_wf (shiftl amount)\<close> \<open>nonneg_delay_conc (shiftl amount)\<close>
    by auto
  ultimately have "inv tw'"
    using \<open>tw, i + 1, shiftl amount \<Rightarrow>\<^sub>S tw'\<close> unfolding sim_hoare_valid_def by blast
  with \<open>i + 1 = fst tw'\<close> show ?thesis
    unfolding inv_def  by (metis less_add_one)
qed

lemma correctness_wityping:
  assumes "sim_fin w (i + 1) (shiftl amount) tw'" and "wityping \<Gamma> w"
  shows   "wityping \<Gamma> (snd tw')"
proof -
  obtain tw where "init_sim (0, w) (shiftl amount) tw" and  "tw, i + 1, (shiftl amount) \<Rightarrow>\<^sub>S tw'"
    using premises_sim_fin_obt[OF assms(1)] by auto
  hence "i + 1 = fst tw'"
    using world_maxtime_lt_fst_tres  by blast
  have "conc_stmt_wf (shiftl amount)"
    unfolding conc_stmt_wf_def shiftl_def by auto
  moreover have "nonneg_delay_conc (shiftl amount)"
    unfolding shiftl_def by auto
  ultimately have "init_sim_valid (\<lambda>tw. fst tw = 0 \<and> wityping \<Gamma> (snd tw)) (shiftl amount) (\<lambda>tw. (inv tw \<and> wityping \<Gamma> (snd tw)) \<and> inv2 tw)"
    using init_sim_hoare_soundness[OF init_sat_inv_comb]
    by (metis (no_types, lifting) conc_wt_cases(1) init_sat_inv_comb
    init_sim_hoare_soundness sub_def strengthen_precondition_init_sim_hoare)
  hence "inv tw \<and> wityping \<Gamma> (snd tw) \<and> inv2 tw"
    using \<open>init_sim (0, w) (shiftl amount) tw\<close> fst_conv assms(2) unfolding init_sim_valid_def
    by (metis snd_conv)
  hence "inv tw" and "inv2 tw" and "wityping \<Gamma> (snd tw)"
    by auto
  moreover have "\<Turnstile>\<^sub>s \<lbrace>\<lambda>tw. (local.inv tw \<and> inv2 tw) \<and> wityping \<Gamma> (snd tw)\<rbrace> Shift_Left_Hoare.shiftl amount \<lbrace>\<lambda>tw. (local.inv tw \<and> inv2 tw) \<and> wityping \<Gamma> (snd tw)\<rbrace>"
    using conc_sim_soundness[OF conc_sim'] \<open>conc_stmt_wf (shiftl amount)\<close> \<open>nonneg_delay_conc (shiftl amount)\<close>
    by blast
  ultimately show "wityping \<Gamma> (snd tw')"
    using \<open>tw, i + 1, (shiftl amount) \<Rightarrow>\<^sub>S tw'\<close> unfolding sim_hoare_valid_def by blast
qed

corollary correctness2:
  assumes "sim_fin w (i + 1) (shiftl amount) tw'" and "wityping \<Gamma> w"
  defines "bsIN  \<equiv> lof_wline tw' IN i"
  defines "bsOUT \<equiv> lof_wline tw' OUT (i + 1)"
  shows   "(\<Sum>i = 0..<length bsOUT. (int \<circ> of_bool) (rev bsOUT ! i) * 2 ^ i) =
          ((\<Sum>i = 0..<length bsIN. (int \<circ> of_bool) (rev bsIN  ! i) * 2 ^ i) * 2 ^ amount) mod 2 ^ len "
proof -
  have "property (i + 1) i tw'" and "wityping \<Gamma> (snd tw')"
    using correctness[OF assms(1-2)] correctness_wityping[OF assms(1-2)] by auto
  hence "lof_wline tw' OUT (i + 1) = drop amount (lof_wline tw' IN i @ replicate amount False)"
    unfolding property_def by auto
  hence "bsOUT = drop amount (bsIN @ replicate amount False)" (is "_ = ?rhs")
    unfolding bsIN_def bsOUT_def by auto
  hence "bl_to_bin bsOUT = bl_to_bin ?rhs"
    by auto
  also have "... = bintrunc (length bsIN) (bl_to_bin (bsIN @ replicate amount False))"
    unfolding bl2bin_drop by auto
  also have "... = bl_to_bin (bsIN @ replicate amount False) mod 2 ^ length bsIN"
    unfolding bintrunc_mod2p by auto
  finally have "bl_to_bin bsOUT = bl_to_bin (bsIN @ replicate amount False) mod 2 ^ length bsIN"
    by auto
  moreover have "bl_to_bin (bsIN @ replicate amount False) = bl_to_bin bsIN * 2 ^ amount"
    by (simp add: bin_cat_num bl_to_bin_app_cat bl_to_bin_rep_False)
  moreover have "len = length bsIN"
    by (smt \<open>wityping \<Gamma> (snd tw')\<close> assms(3) comp_apply ty.distinct(1) ty.inject type_of.elims
    unsigned_shift_left_axioms unsigned_shift_left_def val.sel(3) wityping_def wtyping_def)
  ultimately have "bl_to_bin bsOUT = (bl_to_bin bsIN * 2 ^ amount) mod 2 ^ len"
    by auto
  thus ?thesis
    unfolding bl_to_bin_correctness by auto
qed

end

end


theory "Env-HOLCF"
  imports Env "HOLCF-Utils"
begin

subsubsection \<open>Continuity and pcpo-valued functions\<close>

lemma  override_on_belowI:
  assumes "\<And> a. a \<in> S \<Longrightarrow> y a \<sqsubseteq> z a"
  and "\<And> a. a \<notin> S \<Longrightarrow> x a \<sqsubseteq> z a"
  shows  "x ++\<^bsub>S\<^esub> y \<sqsubseteq> z"
  using assms
  apply -
  apply (rule fun_belowI)
  apply (case_tac "xa \<in> S")
  apply auto
  done

lemma override_on_cont1: "cont (\<lambda> x. x ++\<^bsub>S\<^esub> m)"
  by (rule cont2cont_lambda) (auto simp add: override_on_def)

lemma override_on_cont2: "cont (\<lambda> x. m ++\<^bsub>S\<^esub> x)"
  by (rule cont2cont_lambda) (auto simp add: override_on_def)

lemma override_on_cont2cont[simp, cont2cont]:
  assumes "cont f"
  assumes "cont g"
  shows "cont (\<lambda> x. f x ++\<^bsub>S\<^esub> g x)"
by (rule cont_apply[OF assms(1) override_on_cont1 cont_compose[OF override_on_cont2 assms(2)]])

lemma override_on_mono:
  assumes "x1 \<sqsubseteq> (x2 :: 'a::type \<Rightarrow> 'b::cpo)"
  assumes "y1 \<sqsubseteq> y2"
  shows "x1 ++\<^bsub>S\<^esub> y1 \<sqsubseteq> x2 ++\<^bsub>S\<^esub> y2"
by (rule below_trans[OF cont2monofunE[OF override_on_cont1 assms(1)] cont2monofunE[OF override_on_cont2 assms(2)]])

lemma fun_upd_belowI2:
  assumes "\<And> z . z \<noteq> x \<Longrightarrow> \<rho> z \<sqsubseteq> \<rho>' z"
  assumes "\<rho> x \<sqsubseteq> y"
  shows  "\<rho> \<sqsubseteq> \<rho>'(x := y)"
  apply (rule fun_belowI)
  using assms by auto

lemma env_restr_belowI:
  assumes  "\<And> x. x \<in> S \<Longrightarrow> (m1 f|` S) x \<sqsubseteq> (m2 f|` S) x"
  shows "m1 f|` S \<sqsubseteq> m2 f|` S"
  apply (rule fun_belowI)
  by (metis assms below_bottom_iff lookup_env_restr_not_there)

lemma env_restr_belowI2:
  assumes  "\<And> x. x \<in> S \<Longrightarrow> m1 x \<sqsubseteq> m2 x"
  shows "m1 f|` S \<sqsubseteq> m2"
  by (rule fun_belowI)
     (simp add: assms env_restr_def)

lemma env_restr_below_itself:
  shows "m f|` S \<sqsubseteq> m"
  apply (rule fun_belowI)
  apply (case_tac "x \<in> S")
  apply auto
  done

lemma env_restr_cont:  "cont (env_restr S)"
  apply (rule cont2cont_lambda)
  apply (case_tac "y \<in> S")
  apply auto
  done

lemma env_restr_eqD:
  assumes "m1 f|` S = m2 f|` S"
  assumes "x \<in> S"
  shows "m1 x = m2  x"
  by (metis assms(1) assms(2) lookup_env_restr)

lemma env_restr_below_subset:
  assumes "S \<subseteq> S'"
  and "m1 f|` S' \<sqsubseteq> m2 f|` S'"
  shows "m1 f|` S \<sqsubseteq> m2 f|` S"
using assms
by (auto intro!: env_restr_belowI dest: env_restr_belowD)

lemma  override_on_below_restrI:
  assumes " x f|` (-S) \<sqsubseteq> z f|` (-S)"
  and "y f|` S \<sqsubseteq> z f|` S"
  shows  "x ++\<^bsub>S\<^esub> y \<sqsubseteq> z"
using assms
by (auto intro: override_on_belowI dest:env_restr_belowD)

lemma  fmap_below_add_restrI:
  assumes "x f|` (-S) \<sqsubseteq> y f|` (-S)"
  and     "x f|` S \<sqsubseteq> z f|` S"
  shows  "x \<sqsubseteq> y ++\<^bsub>S\<^esub> z"
using assms
by (auto intro!: fun_belowI dest:env_restr_belowD simp add: lookup_override_on_eq)

lemmas env_restr_cont2cont[simp,cont2cont] = cont_compose[OF env_restr_cont]

lemma env_delete_cont:  "cont (env_delete x)"
  apply (rule cont2cont_lambda)
  apply (case_tac "y = x")
  apply auto
  done
lemmas env_delete_cont2cont[simp,cont2cont] = cont_compose[OF env_delete_cont]

end


theory "HOLCF-Utils"
  imports  HOLCF Pointwise
begin

default_sort type

lemmas cont_fun[simp]
lemmas cont2cont_fun[simp]

lemma cont_compose2:
  assumes "\<And> y. cont (\<lambda> x. c x y)"
  assumes "\<And> x. cont (\<lambda> y. c x y)"
  assumes "cont f"
  assumes "cont g"
  shows "cont (\<lambda>x. c (f x) (g x))"
  by (intro cont_apply[OF assms(4) assms(2)]
            cont2cont_fun[OF cont_compose[OF _ assms(3)]]
            cont2cont_lambda[OF assms(1)])

lemma pointwise_adm:
  fixes P :: "'a::pcpo \<Rightarrow> 'b::pcpo \<Rightarrow> bool"
  assumes "adm (\<lambda> x. P (fst x) (snd x))"
  shows "adm (\<lambda> m. pointwise P (fst m) (snd m))"
proof (rule admI, goal_cases)
  case prems: (1 Y)
  show ?case
    apply (rule pointwiseI)
    apply (rule admD[OF adm_subst[where t = "\<lambda>p . (fst p x, snd p x)" for x, OF _ assms, simplified] \<open>chain Y\<close>])
    using prems(2) unfolding pointwise_def apply auto
    done
qed

lemma cfun_beta_Pair:
  assumes "cont (\<lambda> p. f (fst p) (snd p))"
  shows "csplit\<cdot>(\<Lambda> a b . f a b)\<cdot>(x, y) = f x y"
  apply simp
  apply (subst beta_cfun)
  apply (rule cont2cont_LAM')
  apply (rule assms)
  apply (rule beta_cfun)
  apply (rule cont2cont_fun)
  using assms
  unfolding prod_cont_iff
  apply auto
  done

lemma fun_upd_mono:
  "\<rho>1 \<sqsubseteq> \<rho>2 \<Longrightarrow> v1 \<sqsubseteq> v2 \<Longrightarrow> \<rho>1(x := v1) \<sqsubseteq> \<rho>2(x := v2)"
  apply (rule fun_belowI)
  apply (case_tac "xa = x")
  apply simp
  apply (auto elim:fun_belowD)
  done

lemma fun_upd_cont[simp,cont2cont]:
  assumes "cont f" and "cont h"
  shows "cont (\<lambda> x. (f x)(v := h x) :: 'a \<Rightarrow> 'b::pcpo)"
  by (rule cont2cont_lambda)(auto simp add: assms)

lemma fun_upd_belowI:
  assumes "\<And> z . z \<noteq> x \<Longrightarrow> \<rho> z \<sqsubseteq> \<rho>' z"
  assumes "y \<sqsubseteq> \<rho>' x"
  shows  "\<rho>(x := y) \<sqsubseteq> \<rho>'"
  apply (rule fun_belowI)
  using assms
  apply (case_tac "xa = x")
  apply auto
  done

lemma cont_if_else_above:
  assumes "cont f"
  assumes "cont g"
  assumes "\<And> x. f x \<sqsubseteq> g x"
  assumes "\<And> x y. x \<sqsubseteq> y \<Longrightarrow> P y \<Longrightarrow> P x"
  assumes "adm P"
  shows "cont (\<lambda>x. if P x then f x else g x)" (is "cont ?I")
proof(intro contI2 monofunI)
  fix x y :: 'a
  assume "x \<sqsubseteq> y"
  with assms(4)[OF this]
  show "?I x \<sqsubseteq> ?I y"
    apply (auto)
    apply (rule cont2monofunE[OF assms(1)], assumption)
    apply (rule below_trans[OF cont2monofunE[OF assms(1)] assms(3)], assumption)
    apply (rule cont2monofunE[OF assms(2)], assumption)
    done
next
  fix Y :: "nat \<Rightarrow> 'a"
  assume "chain Y"
  assume "chain (\<lambda>i . ?I (Y i))"

  have ch_f: "f (\<Squnion> i. Y i) \<sqsubseteq> (\<Squnion> i. f (Y i))" by (metis \<open>chain Y\<close> assms(1) below_refl cont2contlubE)

  show "?I (\<Squnion> i. Y i) \<sqsubseteq> (\<Squnion> i. ?I (Y i))"
  proof(cases "\<forall> i. P (Y i)")
    case True hence "P (\<Squnion> i. Y i)" by (metis \<open>chain Y\<close> adm_def assms(5))
    with True ch_f show ?thesis by auto
  next
    case False
    then obtain j where "\<not> P (Y j)" by auto
    hence *:  "\<forall> i \<ge> j. \<not> P (Y i)" "\<not> P (\<Squnion> i. Y i)"
      apply (auto)
      apply (metis assms(4) chain_mono[OF \<open>chain Y\<close>])
      apply (metis assms(4) is_ub_thelub[OF \<open>chain Y\<close>])
      done

    have "?I (\<Squnion> i. Y i) = g (\<Squnion> i. Y i)" using * by simp
    also have "\<dots> = g (\<Squnion> i. Y (i + j))" by (metis lub_range_shift[OF \<open>chain Y\<close>])
    also have "\<dots> = (\<Squnion> i. (g (Y (i + j))))" by (rule cont2contlubE[OF assms(2) chain_shift[OF \<open>chain Y\<close>]] )
    also have "\<dots> = (\<Squnion> i. (?I (Y (i + j))))" using * by auto
    also have "\<dots> = (\<Squnion> i. (?I (Y i)))" by (metis lub_range_shift[OF \<open>chain (\<lambda>i . ?I (Y i))\<close>])
    finally show ?thesis by simp
  qed
qed

fun up2option :: "'a::cpo\<^sub>\<bottom> \<Rightarrow> 'a option"
  where "up2option Ibottom = None"
  |     "up2option (Iup a) = Some a"

lemma up2option_simps[simp]:
  "up2option \<bottom> = None"
  "up2option (up\<cdot>x) = Some x"
  unfolding up_def by (simp_all add: cont_Iup inst_up_pcpo)

fun option2up :: "'a option \<Rightarrow> 'a::cpo\<^sub>\<bottom>"
  where "option2up None = \<bottom>"
  |     "option2up (Some a) = up\<cdot>a"

lemma option2up_up2option[simp]:
  "option2up (up2option x) = x"
  by (cases x) auto
lemma up2option_option2up[simp]:
  "up2option (option2up x) = x"
  by (cases x) auto

lemma adm_subst2: "cont f \<Longrightarrow> cont g \<Longrightarrow> adm (\<lambda>x. f (fst x) = g (snd x))"
  apply (rule admI)
  apply (simp add:
      cont2contlubE[where f = f]  cont2contlubE[where f = g]
      cont2contlubE[where f = snd]  cont2contlubE[where f = fst]
      )
  done

subsubsection \<open>Composition of fun and cfun\<close>

lemma cont2cont_comp [simp, cont2cont]:
  assumes "cont f"
  assumes "\<And> x. cont (f x)"
  assumes "cont g"
  shows "cont (\<lambda> x. (f x) \<circ> (g x))"
  unfolding comp_def
  by (rule cont2cont_lambda)
     (intro cont2cont  \<open>cont g\<close> \<open>cont f\<close> cont_compose2[OF cont2cont_fun[OF assms(1)] assms(2)] cont2cont_fun)

definition cfun_comp :: "('a::pcpo \<rightarrow> 'b::pcpo) \<rightarrow> ('c::type \<Rightarrow> 'a) \<rightarrow> ('c::type \<Rightarrow> 'b)"
  where  "cfun_comp = (\<Lambda> f \<rho>. (\<lambda> x. f\<cdot>x) \<circ> \<rho>)"

lemma cfun_comp_app[simp]: "(cfun_comp\<cdot>f\<cdot>\<rho>) x = f\<cdot>(\<rho> x)"
  unfolding cfun_comp_def by auto

lemma fix_eq_fix:
  "f\<cdot>(fix\<cdot>g) \<sqsubseteq> fix\<cdot>g \<Longrightarrow> g\<cdot>(fix\<cdot>f) \<sqsubseteq> fix\<cdot>f \<Longrightarrow> fix\<cdot>f = fix\<cdot>g"
  by (metis fix_least_below below_antisym)

subsubsection \<open>Additional transitivity rules\<close>

text \<open>
These collect side-conditions of the form @{term "cont f"}, so the usual way to discharge them
is to write @{text[source] "by this (intro cont2cont)+"} at the end.
\<close>

lemma below_trans_cong[trans]:
  "a \<sqsubseteq> f x \<Longrightarrow> x \<sqsubseteq> y \<Longrightarrow> cont f \<Longrightarrow> a \<sqsubseteq> f y "
by (metis below_trans cont2monofunE)

lemma not_bot_below_trans[trans]:
  "a \<noteq> \<bottom> \<Longrightarrow> a \<sqsubseteq> b \<Longrightarrow> b \<noteq> \<bottom>"
  by (metis below_bottom_iff)

lemma not_bot_below_trans_cong[trans]:
  "f a \<noteq> \<bottom> \<Longrightarrow> a \<sqsubseteq> b \<Longrightarrow> cont f \<Longrightarrow> f b \<noteq> \<bottom>"
  by (metis below_bottom_iff cont2monofunE)

end