theory Examples_One_Step_Method
imports
  "HOL-ODE-Numerics.ODE_Numerics"
begin

subsection \<open>Example 1\<close>
experiment begin

schematic_goal e1_fas:
  "[1, (X!1)\<^sup>2 - X!0] = interpret_floatariths ?fas X"
  unfolding power2_eq_square\<comment> \<open>TODO: proper affine implementation of power\<close>
  by (reify_floatariths)

concrete_definition e1_fas uses e1_fas

interpretation e1: ode_interpretation true_form UNIV e1_fas "\<lambda>(x, y). (1, y\<^sup>2 - x)::real*real"
  "d::2" for d
  by unfold_locales (auto simp: e1_fas_def less_Suc_eq_0_disj nth_Basis_list_prod Basis_list_real_def
      mk_ode_ops_def eucl_of_list_prod power2_eq_square intro!: isFDERIV_I)

lemma e1_0: "t \<in> {4 .. 4} \<longrightarrow> (x, y) \<in> {(0, 0) .. (0, 0.71875)} \<longrightarrow>
   t \<in> e1.existence_ivl0 (x, y) \<and> e1.flow0 (x, y) t \<in> {(3.999, -1.96)..(4, -1.9)}"
  by (tactic \<open>ode_bnds_tac @{thms e1_fas_def} 30 20 7 12 [(0, 1, "0x000000")] (* "out_e1_0.out" *) "" @{context} 1\<close>)

lemma e1_1: "t \<in> {4 .. 4} \<longrightarrow> (x, y) \<in> {(0, 0.71875) .. (0, 0.71875)} \<longrightarrow>
   t \<in> e1.existence_ivl0 (x, y) \<and> e1.flow0 (x, y) t \<in> {(3.999, -1.921)..(4, -1.919)}"
  by (tactic \<open>ode_bnds_tac @{thms e1_fas_def} 30 20 7 12 [(0, 1, "0xff0000")] (* "out_e1_1.out" *) "" @{context} 1\<close>)

end

subsection \<open>Example Exponential\<close>
experiment begin

schematic_goal exp_fas:
  "[1, (X!1)] = interpret_floatariths ?fas X"
  by (reify_floatariths)
concrete_definition exp_fas uses exp_fas

interpretation exp_ivp: ode_interpretation true_form UNIV exp_fas
  "\<lambda>(t::real, x). (1, x::real)" "one::2"
  by standard
    (auto simp: exp_fas_def less_Suc_eq_0_disj nth_Basis_list_prod Basis_list_real_def
      mk_ode_ops_def eucl_of_list_prod power2_eq_square intro!: isFDERIV_I)

subsubsection \<open>connection to exponential function\<close>

lemma exp_ivp_existence_ivl0:
  "exp_ivp.existence_ivl0 p = UNIV"
  by (rule exp_ivp.existence_ivl_eq_domain)
     (auto intro!: exI[where x=1] order_trans[OF norm_Pair_le] order_trans[OF _ norm_snd_le])

lemma exp_eq_exp_ivp_aux:
  "exp_ivp.flow0 (0, 1) x = (x, exp x)"
  apply (rule exp_ivp.flow_unique[where phi="\<lambda>x. (x, exp x)"])
  unfolding exp_ivp_existence_ivl0
  by (auto simp: has_vector_derivative_def intro!: derivative_eq_intros)

lemma ex_eq_exp_ivp: "exp x = snd (exp_ivp.flow0 (0, 1) x)"
  unfolding exp_eq_exp_ivp_aux by simp

text \<open>concrete example\<close>

lemma exp_ode_result:
  "t \<in> {1 .. 1} \<longrightarrow> (s, x) \<in> {(0, 1) .. (0, 1)} \<longrightarrow>
  t \<in> exp_ivp.existence_ivl0 (s, x) \<and>
  exp_ivp.flow0 (s, x) t \<in> {(0.99, 2.718281) .. (1, 2.718284)}"
  by (tactic \<open>ode_bnds_tac @{thms exp_fas_def} 30 20 7 20 [(0, 1, "0x000000")] (* "out_exp.out" *) "" @{context} 1\<close>)

lemma exp1: "exp 1 \<in> {2.718281 .. 2.718284::real}"
  using exp_ode_result[of 1 0 1]
  by (auto simp: exp_eq_exp_ivp_aux)

end

subsection \<open>Van der Pol\<close>
experiment begin

schematic_goal vdp_fas:
  "[X!1, X!1 * (1 - (X!0)\<^sup>2) - X!0] = interpret_floatariths ?fas X"
  unfolding power2_eq_square\<comment> \<open>TODO: proper affine implementation of power\<close>
  by (reify_floatariths)

concrete_definition vdp_fas uses vdp_fas

interpretation vdp: ode_interpretation true_form UNIV vdp_fas "\<lambda>(x, y). (y, y * (1 - x\<^sup>2) - x)::real*real"
  "n::2" for n
  by standard
    (auto simp: vdp_fas_def less_Suc_eq_0_disj nth_Basis_list_prod Basis_list_real_def
      mk_ode_ops_def eucl_of_list_prod power2_eq_square intro!: isFDERIV_I)

lemma vdp_c0: "t \<in> point_ivl 7 \<longrightarrow> (x, y) \<in> point_ivl (1.4, 2.4) \<longrightarrow>
   t \<in> vdp.existence_ivl0 (x, y) \<and> vdp.flow0 (x, y) t \<in> {(1.870, 0.9887) .. (1.875, 1.001)}"
  by (tactic \<open>ode_bnds_tac @{thms vdp_fas_def} 30 35 9 14 [(0, 1, "0x000000")] (* "out_vdp_c0.out" *) "" @{context} 1\<close>)

lemma vdp_c1: "t \<in> point_ivl 7 \<longrightarrow> (x, y) \<in> point_ivl (1.4, 2.4) \<longrightarrow>
   t \<in> vdp.existence_ivl0 (x, y) \<and>
   vdp.flow0 (x, y) t \<in> {(1.870, 0.9887) .. (1.875, 1.001)} \<and>
    vdp.Dflow (x, y) t o\<^sub>L blinfun_of_list [1,0, 0,1] \<in>
      vdp.blinfuns_of_lvivl ([-0.197,-0.399, 0.835, 1.71],
                             [-0.189, -0.387, 0.858, 1.75])"
  by (tactic \<open>ode'_bnds_tac @{thms vdp_fas_def} 30 80 40 14
    [(0, 1, "0x000000", [0,1])] ["0x7f0000", "0x00007f"] (* "out_vdp_c1.out" *) "" @{context} 1\<close>)
end

subsection \<open>Example Classical Lorenz Equations\<close>
experiment begin

schematic_goal
  lorenz_fas:
  "[10 * (X!1 - X!0),
    X!0 * (28 - X!2) - X!1,
    X!0 * X!1 - 8 /3 * X!2] =
  interpret_floatariths ?fas X"
  by (reify_floatariths)
concrete_definition lorenz_fas uses lorenz_fas

interpretation lorenz: ode_interpretation true_form UNIV lorenz_fas
  "\<lambda>(x, y, z). (10 * (y - x), x * (28 - z) - y, x * y - 8 / 3 * z)
    ::real*real*real"
  "three::3"
  by standard
    (auto simp: lorenz_fas_def less_Suc_eq_0_disj nth_Basis_list_prod Basis_list_real_def
      mk_ode_ops_def eucl_of_list_prod power2_eq_square intro!: isFDERIV_I)

text \<open>Taken from "A database of rigorous and high-precision periodic orbits of the Lorenz model" (2015)
  by Barrio, Dena, Tucker\<close>
lemma lorenz_c0: "t \<in> point_ivl 1.558652210 \<longrightarrow> (x, y, z) \<in> point_ivl ( -2.147367631, 2.078048211, 27) \<longrightarrow>
   t \<in> lorenz.existence_ivl0 (x, y, z) \<and> lorenz.flow0 (x, y, z) t \<in> {(-2.1515, 2.0738, 26.992) .. (-2.1434, 2.0824, 27.009)}"
  by (tactic \<open>ode_bnds_tac @{thms lorenz_fas_def} 30 35 9 16
    [(0, 1, "0x7f0000"), (0, 2, "0x00007f")] (* "out_lorenz_c0.out" *) "" @{context} 1\<close>)

lemma lorenz_c1: "t \<in> point_ivl (FloatR 52299689 (- 25) \<comment> \<open>for C1-info, the target time needs to be a float\<close>) \<longrightarrow>
  (x, y, z) \<in> point_ivl ( -2.147367631, 2.078048211, 27) \<longrightarrow>
   t \<in> lorenz.existence_ivl0 (x, y, z) \<and>
   lorenz.flow0 (x, y, z) t \<in> {(-2.158, 2.064, 26.98) .. (-2.137, 2.092, 27.02)} \<and>
    lorenz.Dflow (x, y, z) t o\<^sub>L blinfun_of_list [1,0,0, 0,1,0, 0,0,1] \<in>
      lorenz.blinfuns_of_lvivl ([-0.535,-1.15,-0.794, 1.49,4.01,0.651, 2.71,6.85,2.11],
                                [-0.479,-1.03,-0.751, 1.58,4.14,0.703, 2.82,7.00,2.19])"
  by (tactic \<open>ode'_bnds_tac @{thms lorenz_fas_def} 30 80 40 16
    [(0, 1, "0x000000", [0,1,2]), (0, 2, "0x7f7f7f", [0,1,2])] ["0x7f0000", "0x007f00", "0x00007f"]
      (* "out_lorenz_c1.out" *) "" @{context} 1\<close>)
end

subsection \<open>Bessel Function inspired example\<close>
text \<open>\label{sec:bessel}\<close>
experiment begin

unbundle floatarith_notation

text \<open>encoding a constant parameter and higher derivatives in the ode...\<close>

schematic_goal bessel_fas:
  "[0, -1, -(X!3), (((X!1)\<^sup>2 - (X!0)\<^sup>2) * X!2 + (X!1) * (X!3)) / (X!1)\<^sup>2] = interpret_floatariths ?fas X"
  unfolding power2_eq_square\<comment> \<open>TODO: proper affine implementation of power\<close>
  by (reify_floatariths)
concrete_definition bessel_fas uses bessel_fas

interpretation bessel: ode_interpretation "Less (Var 1) (Num 0)" "{(mu, s, _, _). s < 0}"
  bessel_fas
  "\<lambda>(mu::real, s::real, x::real, x'::real).
  (0::real,
  -1::real,
  -x'::real,
  (((s\<^sup>2 - mu\<^sup>2) * x + s * x') / s\<^sup>2))"
  "four::4"
  by standard
    (auto simp: bessel_fas_def less_Suc_eq_0_disj nth_Basis_list_prod Basis_list_real_def inverse_eq_divide
      mk_ode_ops_def eucl_of_list_prod power2_eq_square intro!: isFDERIV_I)

definition "J0 = 0.765197686557966551449717526103"
definition "J0' = 0.440050585744933515959682203719"

lemma bessel_result:
  "t \<in> {10 .. 10} \<longrightarrow>
   (x, y, j0, j0') \<in> {(0, -1, 0.765197686557966551449717526103, 0.440050585744933515959682203719) ..
      (0, -1, 0.765197686557966551449717526103, 0.440050585744933515959682203719)} \<longrightarrow>
   t \<in> bessel.existence_ivl0 (x, y, j0, j0') \<and>
                bessel.flow0 (x, y, j0, j0') t \<in> {(0, -11.01, -0.18, -0.185) .. (0, -11, -0.165, -0.169)}"
  by (tactic \<open>ode_bnds_tac @{thms bessel_fas_def} 30 20 7 12
    [(1, 2, "0x007f00"), (1, 3, "0x00007f")] (* "out_bessel.out" *) "" @{context} 1\<close>)
end

subsection \<open> Oil reservoir in Affine arithmetic \<close>
text \<open>\label{sec:exampleoil}\<close>
experiment begin

schematic_goal oil_fas:
  "[X!1, (X!1)\<^sup>2 - 3 / (0.001 + (X!0)\<^sup>2)] = interpret_floatariths ?fas X"
  unfolding power2_eq_square\<comment> \<open>TODO: proper affine implementation of power\<close>
  by (reify_floatariths)

concrete_definition oil_fas uses oil_fas

lemma oil_deriv_ok: fixes y::real
shows "1 / 1000 + y*y = 0 \<longleftrightarrow> False"
proof -
  have "1 / 1000 + y*y > 0"
    by (auto intro!: add_pos_nonneg)
  thus ?thesis by auto
qed

interpretation oil: ode_interpretation true_form UNIV oil_fas
  "\<lambda>(y, z). (z, z\<^sup>2 - 3 / (0.001 + y\<^sup>2))::real*real" "two::2"
  by standard
    (auto simp: oil_fas_def oil_deriv_ok less_Suc_eq_0_disj nth_Basis_list_prod Basis_list_real_def inverse_eq_divide
      mk_ode_ops_def eucl_of_list_prod isDERIV_Power_iff power2_eq_square intro!: isFDERIV_I)

theorem oil_20:
  "t \<in> {50 .. 50} \<longrightarrow> (x, y) \<in> {(10, 0) .. (10, 0)} \<longrightarrow>
   t \<in> oil.existence_ivl0 (x, y) \<and> oil.flow0 (x, y) t \<in> {(-8.310, -0.2252) .. (-8.257, -0.2236)}"
  by (tactic \<open>ode_bnds_tac @{thms oil_fas_def} 30 20 7 20 [(0, 1, "0x000000")] (* "out_oil_20.out" *) "" @{context} 1\<close>)

theorem oil_30:
  "t \<in> {50 .. 50} \<longrightarrow> (x, y) \<in> {(10, 0) .. (10, 0)} \<longrightarrow>
   t \<in> oil.existence_ivl0 (x, y) \<and> oil.flow0 (x, y) t \<in> {(-8.279, -0.2246) .. (-8.276, -0.2245)}"
  by (tactic \<open>ode_bnds_tac @{thms oil_fas_def} 30 20 7 30 [(0, 1, "0xff0000")] (* "out_oil_30.out" *) "" @{context} 1\<close>)
end

subsection \<open>Example V in Walter's textbook~\cite{walter}\<close>
experiment begin

schematic_goal e3_fas:
  "[1, (X!1)\<^sup>2 + (X!0)\<^sup>2] = interpret_floatariths ?fas X"
  unfolding power2_eq_square\<comment> \<open>TODO: proper affine implementation of power\<close>
  by (reify_floatariths)
concrete_definition e3_fas uses e3_fas

interpretation e3: ode_interpretation true_form UNIV e3_fas "\<lambda>(t, x). (1, x\<^sup>2 + t\<^sup>2)::real*real"
  "d::2" for d
  by standard
    (auto simp: e3_fas_def less_Suc_eq_0_disj nth_Basis_list_prod Basis_list_real_def
      mk_ode_ops_def eucl_of_list_prod power2_eq_square intro!: isFDERIV_I)

lemma e3_flow_mem:
  "t \<in> {0.125 .. 0.125} \<longrightarrow> (s, x) \<in> {(0, 1) .. (0, 1)} \<longrightarrow>
  t \<in> e3.existence_ivl0 (s, x) \<and> (e3.flow0 (s, x) t \<in> {(0.124, 1.14347) .. (0.126, 1.14376)})"
  by (tactic \<open>ode_bnds_tac @{thms e3_fas_def} 30 20 7 11 [(0, 1, "0x000000")] (* "out_e2.out" *) "" @{context} 1\<close>)

subsubsection \<open>Walter's analytical obtained by in section 9, Example V.\<close>

lemma cos_neq_zeroI:
  assumes "-pi / 2 < x" "x < pi / 2"
  shows "cos x \<noteq> 0"
  using assms div2_less_self
  by (fastforce simp: cos_zero_iff)

lemma quadratic_real_max_eq:
  fixes a b c x::real
  defines "xm \<equiv> -b / (2 * a)"
  shows "a < 0 \<Longrightarrow> a * x\<^sup>2 + b * x + c \<le> a * xm\<^sup>2 + b * xm + c"
  unfolding xm_def
  by (sos "(((((A<0 * (A<1 * A<2)) * R<1) + ((A<2 * R<1) * (R<1 * [a^2]^2)))) &
    ((((A<0 * (A<1 * A<2)) * R<1) + ((R<1 * (R<1/2 * [2*a^4*x + a^3*b]^2)) +
    ((A<0 * (A<1 * R<1)) * (R<1/2 * [2*a^2*x + a*b]^2))))))")

definition "f = (\<lambda>t x. t\<^sup>2 + x\<^sup>2::real)"

lemma ll: "local_lipschitz UNIV UNIV f"
  by (rule c1_implies_local_lipschitz[where f'="\<lambda>(t, x). blinfun_scaleR_left (blinfun_scaleR_left id_blinfun 2) x"])
    (auto intro!: continuous_intros derivative_eq_intros ext simp: f_def split_beta' blinfun.bilinear_simps)

lemma cont: "continuous_on UNIV (\<lambda>t. f t x)"
  by (auto intro!: continuous_intros simp: f_def)

interpretation ll_on_open_real UNIV f UNIV by unfold_locales (auto intro!: ll cont)

definition f1::"real \<Rightarrow> real \<Rightarrow> real" where "f1 t x \<equiv> x\<^sup>2"
definition v::"real \<Rightarrow> real" where "v t = 1 / (1 - t)"

lemma v: "(v solves_ode f1) {0..<1} UNIV" and "v 0 = 1"
  by (auto intro!: solves_odeI derivative_eq_intros ext
    simp: v_def has_vderiv_on_def f1_def has_vector_derivative_def divide_simps power2_eq_square)

lemma
  lower_bound:
  assumes y: "(y solves_ode f) {0 ..< t1} UNIV"
    and iv: "y 0 = 1"
    and t: "t1 < 1" "t \<in> {0 ..< t1}"
  shows "v t \<le> y t"
  using y[THEN solves_ode_on_subset] solves_odeD(1)[OF v, THEN has_vderiv_on_subset]
  apply (rule lower_solution[where ?t0.0 = 0])
  using t
  by (auto simp: f1_def f_def v_def iv)

definition f2::"real \<Rightarrow> real \<Rightarrow> real" where "f2 t x \<equiv> 1 + x\<^sup>2"
definition w::"real \<Rightarrow> real" where "w t = tan (t + pi / 4)"

lemma upper_bound:
  assumes y: "(y solves_ode f) {0 ..< t1} UNIV"
    and iv: "y 0 = 1"
    and t: "t1 < pi / 4" "t \<in> {0 ..< t1}"
  shows "y t \<le> w t"
  using y[THEN solves_ode_on_subset] solves_odeD(1)[OF w,THEN has_vderiv_on_subset]
  apply (rule upper_solution[where ?t0.0 = 0])
  using t pi_less_4
  by (auto simp: f2_def f_def w_def iv abs_square_less_1 tan_45)

context
  fixes a::real
  assumes a: "a > 1"
  assumes cond: "1 < 16 * a\<^sup>2 * (a - 1)"
begin

definition w1::"real \<Rightarrow> real" where "w1 t = 1 / (1 - a * t)"
definition w1'::"real \<Rightarrow> real" where "w1' t = a / ((1 - a * t)\<^sup>2)"

lemma w1_lower:
  assumes s: "s < 1 / a" "0 < s"
  shows "f s (w1 s) < w1' s"
proof -
  define smax where "smax \<equiv> 1 / (2 * a)"
  have "a - 1 > (1 - a * s)\<^sup>2 * s\<^sup>2"
  proof -
    have "sqrt ((1 - a * s)\<^sup>2 * s\<^sup>2) = (1 - a * s) * s"
      using a s
      by (auto simp: power_mult_distrib[symmetric] algebra_simps divide_simps
        split: if_split_asm)
    also have "\<dots> = (- a) * s\<^sup>2 + 1 * s + 0" by (simp add: algebra_simps power2_eq_square)
    also have "\<dots> \<le> (1 - a * smax) * smax"
      apply (rule order_trans[OF quadratic_real_max_eq])
      using a s
      by (auto simp: smax_def divide_simps algebra_simps power2_eq_square)
    finally have "((1 - a * s)\<^sup>2 * s\<^sup>2) \<le> (1 - a * smax)\<^sup>2 * smax\<^sup>2"
      unfolding power_mult_distrib[symmetric]
      by (simp add: sqrt_le_D)
    also have "\<dots> < a - 1"
      using a s cond
      by (auto simp add: smax_def power2_eq_square algebra_simps  divide_simps split: if_splits)
    finally show ?thesis .
  qed
  then have "s\<^sup>2 < (a - 1) / (1 - a * s)\<^sup>2"
    using a s
    by (auto simp: divide_simps algebra_simps)
  then have "s\<^sup>2 + (1 / (1 - a * s))\<^sup>2 < a / (1 - a * s)\<^sup>2"
    by (simp add: diff_divide_distrib algebra_simps power_one_over)
  then show ?thesis by (simp add: w1_def w1'_def f_def)
qed

lemma w1: "(w1 has_vderiv_on w1') {0..<1/a}"
  by (auto intro!: derivative_eq_intros split: if_splits
    simp: w1_def w1'_def has_vderiv_on_def has_vector_derivative_def
      algebra_simps divide_simps power2_eq_square)

lemma upper_bound1:
  assumes y: "(y solves_ode f) {0 ..< t1} UNIV"
    and iv: "y 0 = 1"
    and t: "t1 < 1 / a" "t \<in> {0 ..< t1}"
  shows "y t \<le> w1 t"
proof -
  have less_one: "s * a < 1" if a1: "s < t1" and a2: "t1 * a < 1" for s
  proof -
    have "0 < a"
      using a by linarith
    then have "a * s \<le> t1 * a"
      using a1 by (metis (no_types) less_eq_real_def mult.commute real_mult_le_cancel_iff2)
    then have "a * s < 1"
      using a2 by linarith
    then show ?thesis
      by (metis mult.commute)
  qed
  show ?thesis
    using y[THEN solves_ode_on_subset] w1[THEN has_vderiv_on_subset] w1_lower
    apply (rule upper_solution[where ?t0.0 = 0 and S = "{0 ..< t1}"])
    using t a
    by (auto simp: less_one w1_def f_def w1'_def iv divide_simps)
qed

end

definition w16::"real \<Rightarrow> real" where "w16 t = 16 / (16 - 17 * t)"

lemma upper_bound16:
  assumes y: "(y solves_ode f) {0 ..< t1} UNIV"
    and iv: "y 0 = 1"
    and t: "t1 < 16 / 17" "t \<in> {0 ..< t1}"
  shows "y t \<le> w16 t"
  using upper_bound1[of "17/16" y t1 t] assms
  by (simp add: divide_simps w1_def w16_def)

lemma approx_lower_bound:
  "1.142857139 \<le> v 0.125"
  unfolding v_def
  by (approximation 40)

lemma approx_upper_bound:
  "w 0.125 \<le> 1.287426955"
  unfolding w_def
  by (approximation 40)

lemma approx_upper_bound16:
  "w16 0.125 \<le> 1.153153155"
  unfolding w16_def
  by (approximation 40)

end

subsection \<open>Building\<close>
experiment begin

text \<open>Benchmark from the ARCH friendly competition: group AFF. This example is out of the scope of
the current ODE solver: dimension is very high, and without matrix exponential, the ODE solver is
too unstable.\<close>

definition "x1'  x == x ! 25"
definition "x2'  x == x ! 26"
definition "x3'  x == x ! 27"
definition "x4'  x == x ! 28"
definition "x5'  x == x ! 29"
definition "x6'  x == x ! 30"
definition "x7'  x == x ! 31"
definition "x8'  x == x ! 32"
definition "x9'  x == x ! 33"
definition "x10' x == x ! 34"
definition "x11' x == x ! 35"
definition "x12' x == x ! 36"
definition "x13' x == x ! 37"
definition "x14' x == x ! 38"
definition "x15' x == x ! 39"
definition "x16' x == x ! 40"
definition "x17' x == x ! 41"
definition "x18' x == x ! 42"
definition "x19' x == x ! 43"
definition "x20' x == x ! 44"
definition "x21' x == x ! 45"
definition "x22' x == x ! 46"
definition "x23' x == x ! 47"
definition "x24' x == x ! 48"
definition "x25' x == 0.013697*(x!49) - 606.16*x!1 + 34.67*x!2 - 5.0432*x!3 - 734.04*x!4 + 124.55*x!5 - 302.91*x!6 - 98.21*x!7 - 2.204*x!8 - 10.668*x!9 - 41.864*x!10 + 8.1784*x!11 + 51.36*x!12 - 10.956*x!13 - 2.3086*x!14 - 11.998*x!15 - 42.003*x!16 + 4.9418*x!17 - 1.5216*x!18 - 10.35*x!19 + 8.6969*x!20 + 14.96*x!21 + 37.885*x!22 - 24.546*x!23 - 19.3*x!24 - 1.1333*x!25 + 0.036523*x!26 - 0.0053128*x!27 - 0.77328*x!28 + 0.13121*x!29 - 0.3191*x!30 - 0.10346*x!31 - 0.0023218*x!32 - 0.011238*x!33 - 0.044102*x!34 + 0.0086155*x!35 + 0.054106*x!36 - 0.011541*x!37 - 0.002432*x!38 - 0.012639*x!39 - 0.044248*x!40 + 0.0052059*x!41 - 0.0016029*x!42 - 0.010904*x!43 + 0.0091618*x!44 + 0.01576*x!45 + 0.03991*x!46 - 0.025858*x!47 - 0.020331*x!48"
definition "x26' x == 33.51*x!1 - 664.52*x!2 + 79.773*x!3 + 207.45*x!4 + 829.03*x!5 + 94.055*x!6 - 4.3133*x!7 - 136.48*x!8 + 16.276*x!9 + 28.243*x!10 - 76.936*x!11 - 0.55452*x!12 + 30.931*x!13 + 51.904*x!14 + 11.87*x!15 + 9.6948*x!16 - 15.613*x!17 + 15.14*x!18 + 7.6133*x!19 - 5.7122*x!20 + 3.7841*x!21 - 21.172*x!22 - 29.014*x!23 + 10.245*x!24 + 0.035301*x!25 - 1.1948*x!26 + 0.084037*x!27 + 0.21854*x!28 + 0.87334*x!29 + 0.099082*x!30 - 0.0045438*x!31 - 0.14378*x!32 + 0.017146*x!33 + 0.029753*x!34 - 0.081048*x!35 - 0.00058416*x!36 + 0.032585*x!37 + 0.054679*x!38 + 0.012505*x!39 + 0.010213*x!40 - 0.016447*x!41 + 0.01595*x!42 + 0.0080202*x!43 - 0.0060176*x!44 + 0.0039864*x!45 - 0.022303*x!46 - 0.030565*x!47 + 0.010792*x!48"
definition "x27' x == 76.572*x!2 - 3.4577*x!1 - 799.41*x!3 - 347.78*x!4 - 142.59*x!5 + 867.7*x!6 - 165.08*x!7 + 36.992*x!8 + 91.256*x!9 - 66.266*x!10 + 26.434*x!11 + 39.519*x!12 + 67.373*x!13 - 32.177*x!14 + 17.164*x!15 + 133.45*x!16 + 34.378*x!17 + 6.5652*x!18 + 27.869*x!19 - 51.473*x!20 + 41.979*x!21 - 44.928*x!22 + 34.417*x!23 + 30.824*x!24 - 0.0036425*x!25 + 0.080665*x!26 - 1.3369*x!27 - 0.36637*x!28 - 0.15021*x!29 + 0.91408*x!30 - 0.17391*x!31 + 0.038969*x!32 + 0.096134*x!33 - 0.069808*x!34 + 0.027847*x!35 + 0.041632*x!36 + 0.070975*x!37 - 0.033897*x!38 + 0.018082*x!39 + 0.14058*x!40 + 0.036215*x!41 + 0.0069161*x!42 + 0.029358*x!43 - 0.054224*x!44 + 0.044223*x!45 - 0.04733*x!46 + 0.036257*x!47 + 0.032471*x!48"
definition "x28' x == 206.8*x!2 - 734.86*x!1 - 348.32*x!3 - 1910.4*x!4 - 135.41*x!5 - 218.05*x!6 - 1130.0*x!7 + 263.61*x!8 - 178.6*x!9 - 285.02*x!10 + 65.125*x!11 + 125.09*x!12 - 78.164*x!13 - 2.0288*x!14 + 11.414*x!15 - 54.481*x!16 - 17.625*x!17 - 14.273*x!18 - 13.334*x!19 + 11.514*x!20 + 88.076*x!21 + 56.304*x!22 - 12.53*x!23 + 19.497*x!24 - 0.77414*x!25 + 0.21785*x!26 - 0.36694*x!27 - 2.5072*x!28 - 0.14264*x!29 - 0.2297*x!30 - 1.1904*x!31 + 0.2777*x!32 - 0.18815*x!33 - 0.30026*x!34 + 0.068606*x!35 + 0.13177*x!36 - 0.082342*x!37 - 0.0021372*x!38 + 0.012024*x!39 - 0.057393*x!40 - 0.018567*x!41 - 0.015036*x!42 - 0.014047*x!43 + 0.012129*x!44 + 0.092784*x!45 + 0.059314*x!46 - 0.013199*x!47 + 0.020539*x!48"
definition "x29' x == 126.41*x!1 + 830.41*x!2 - 142.11*x!3 - 134.84*x!4 - 1968.7*x!5 + 54.561*x!6 + 141.8*x!7 + 1183.9*x!8 + 118.23*x!9 - 32.897*x!10 + 295.19*x!11 - 13.727*x!12 - 6.9809*x!13 - 150.49*x!14 - 16.631*x!15 + 76.503*x!16 + 25.453*x!17 + 26.848*x!18 + 8.696*x!19 - 20.18*x!20 - 16.511*x!21 + 8.533*x!22 + 112.09*x!23 + 9.1024*x!24 + 0.13317*x!25 + 0.8748*x!26 - 0.14971*x!27 - 0.14205*x!28 - 2.5687*x!29 + 0.057478*x!30 + 0.14938*x!31 + 1.2472*x!32 + 0.12455*x!33 - 0.034656*x!34 + 0.31097*x!35 - 0.014461*x!36 - 0.0073541*x!37 - 0.15853*x!38 - 0.01752*x!39 + 0.080592*x!40 + 0.026813*x!41 + 0.028283*x!42 + 0.0091609*x!43 - 0.021259*x!44 - 0.017394*x!45 + 0.0089891*x!46 + 0.11808*x!47 + 0.009589*x!48"
definition "x30' x == 89.14*x!2 - 308.62*x!1 + 845.85*x!3 - 220.15*x!4 + 49.494*x!5 - 2326.8*x!6 + 132.76*x!7 + 67.169*x!8 - 1400.6*x!9 + 24.168*x!10 + 24.278*x!11 - 85.266*x!12 - 294.4*x!13 + 127.92*x!14 - 24.456*x!15 - 379.06*x!16 - 100.16*x!17 - 46.537*x!18 - 67.411*x!19 + 169.3*x!20 - 100.19*x!21 + 200.07*x!22 - 126.91*x!23 - 44.045*x!24 - 0.32511*x!25 + 0.093904*x!26 + 0.89106*x!27 - 0.23192*x!28 + 0.052139*x!29 - 2.9459*x!30 + 0.13986*x!31 + 0.07076*x!32 - 1.4755*x!33 + 0.02546*x!34 + 0.025576*x!35 - 0.089824*x!36 - 0.31014*x!37 + 0.13476*x!38 - 0.025763*x!39 - 0.39932*x!40 - 0.10551*x!41 - 0.049024*x!42 - 0.071015*x!43 + 0.17835*x!44 - 0.10555*x!45 + 0.21077*x!46 - 0.13369*x!47 - 0.046399*x!48"
definition "x31' x == 140.17*x!5 - 3.2644*x!2 - 166.03*x!3 - 1130.1*x!4 - 97.135*x!1 + 149.9*x!6 - 2042.2*x!7 + 77.153*x!8 + 122.7*x!9 - 1223.6*x!10 - 66.505*x!11 + 249.18*x!12 - 16.632*x!13 + 2.6274*x!14 + 56.399*x!15 - 46.871*x!16 - 118.4*x!17 - 62.011*x!18 - 2.1658*x!19 - 30.269*x!20 + 130.25*x!21 + 5.2191*x!22 - 24.931*x!23 + 6.3303*x!24 - 0.10233*x!25 - 0.0034389*x!26 - 0.17491*x!27 - 1.1905*x!28 + 0.14767*x!29 + 0.15792*x!30 - 2.6461*x!31 + 0.081277*x!32 + 0.12926*x!33 - 1.289*x!34 - 0.07006*x!35 + 0.2625*x!36 - 0.01752*x!37 + 0.0027678*x!38 + 0.059414*x!39 - 0.049377*x!40 - 0.12472*x!41 - 0.065326*x!42 - 0.0022816*x!43 - 0.031887*x!44 + 0.13721*x!45 + 0.005498*x!46 - 0.026264*x!47 + 0.0066687*x!48"
definition "x32' x == 34.596*x!3 - 138.29*x!2 - 2.5435*x!1 + 264.02*x!4 + 1185.0*x!5 + 58.931*x!6 + 77.078*x!7 - 2124.4*x!8 - 54.178*x!9 + 240.2*x!10 - 1279.6*x!11 + 14.033*x!12 + 37.313*x!13 + 238.99*x!14 + 1.7648*x!15 - 96.468*x!16 + 33.324*x!17 - 103.99*x!18 - 129.69*x!19 + 35.961*x!20 + 34.916*x!21 - 10.09*x!22 - 99.84*x!23 - 13.713*x!24 - 0.0026795*x!25 - 0.14568*x!26 + 0.036445*x!27 + 0.27814*x!28 + 1.2484*x!29 + 0.062081*x!30 + 0.081198*x!31 - 2.7327*x!32 - 0.057074*x!33 + 0.25304*x!34 - 1.348*x!35 + 0.014783*x!36 + 0.039308*x!37 + 0.25177*x!38 + 0.0018592*x!39 - 0.10162*x!40 + 0.035106*x!41 - 0.10955*x!42 - 0.13662*x!43 + 0.037884*x!44 + 0.036783*x!45 - 0.010629*x!46 - 0.10518*x!47 - 0.014446*x!48"
definition "x33' x == 54.576*x!3 - 4.3846*x!2 - 11.068*x!1 - 167.43*x!4 + 119.06*x!5 - 1413.1*x!6 + 116.3*x!7 - 50.978*x!8 - 2668.8*x!9 + 58.12*x!10 + 61.221*x!11 - 299.51*x!12 - 1455.4*x!13 + 600.59*x!14 - 14.962*x!15 - 609.81*x!16 - 179.98*x!17 - 140.89*x!18 - 67.425*x!19 + 261.44*x!20 - 215.8*x!21 + 374.46*x!22 - 267.83*x!23 - 167.39*x!24 - 0.01166*x!25 - 0.004619*x!26 + 0.057493*x!27 - 0.17638*x!28 + 0.12543*x!29 - 1.4886*x!30 + 0.12251*x!31 - 0.053703*x!32 - 3.3062*x!33 + 0.061226*x!34 + 0.064493*x!35 - 0.31552*x!36 - 1.5332*x!37 + 0.63269*x!38 - 0.015762*x!39 - 0.6424*x!40 - 0.1896*x!41 - 0.14842*x!42 - 0.071029*x!43 + 0.27541*x!44 - 0.22734*x!45 + 0.39448*x!46 - 0.28215*x!47 - 0.17634*x!48"
definition "x34' x == 29.028*x!2 - 42.219*x!1 - 59.833*x!3 - 284.78*x!4 - 31.96*x!5 + 16.189*x!6 - 1220.6*x!7 + 238.17*x!8 + 45.965*x!9 - 2290.9*x!10 + 219.74*x!11 + 1329.3*x!12 - 104.55*x!13 - 231.45*x!14 + 196.73*x!15 - 91.293*x!16 - 418.1*x!17 - 203.17*x!18 + 77.147*x!19 - 64.407*x!20 + 127.6*x!21 - 66.422*x!22 + 17.647*x!23 + 14.772*x!24 - 0.044476*x!25 + 0.03058*x!26 - 0.063031*x!27 - 0.3*x!28 - 0.033668*x!29 + 0.017054*x!30 - 1.2858*x!31 + 0.2509*x!32 + 0.048422*x!33 - 2.9081*x!34 + 0.23149*x!35 + 1.4003*x!36 - 0.11014*x!37 - 0.24382*x!38 + 0.20725*x!39 - 0.096173*x!40 - 0.44045*x!41 - 0.21403*x!42 + 0.08127*x!43 - 0.06785*x!44 + 0.13442*x!45 - 0.069972*x!46 + 0.01859*x!47 + 0.015562*x!48"
definition "x35' x == 5.3147*x!1 - 77.32*x!2 + 33.098*x!3 + 62.873*x!4 + 295.95*x!5 + 11.239*x!6 - 66.808*x!7 - 1279.2*x!8 + 57.198*x!9 + 221.07*x!10 - 2387.6*x!11 + 120.01*x!12 + 572.58*x!13 + 1229.1*x!14 + 124.63*x!15 - 56.089*x!16 + 180.3*x!17 - 312.48*x!18 - 445.95*x!19 - 24.274*x!20 + 86.343*x!21 - 2.8317*x!22 - 45.574*x!23 - 33.346*x!24 + 0.0055988*x!25 - 0.081453*x!26 + 0.034867*x!27 + 0.066234*x!28 + 0.31177*x!29 + 0.011839*x!30 - 0.070379*x!31 - 1.3476*x!32 + 0.060255*x!33 + 0.23288*x!34 - 3.0099*x!35 + 0.12643*x!36 + 0.60318*x!37 + 1.2948*x!38 + 0.13129*x!39 - 0.059087*x!40 + 0.18994*x!41 - 0.32918*x!42 - 0.46979*x!43 - 0.025571*x!44 + 0.090958*x!45 - 0.002983*x!46 - 0.04801*x!47 - 0.035129*x!48"
definition "x36' x == 48.409*x!1 - 3.7335*x!2 + 32.385*x!3 + 123.4*x!4 - 10.509*x!5 - 100.46*x!6 + 251.0*x!7 + 15.115*x!8 - 306.96*x!9 + 1327.9*x!10 + 119.59*x!11 - 2059.6*x!12 - 316.77*x!13 + 309.66*x!14 - 870.95*x!15 - 176.05*x!16 + 612.8*x!17 + 311.81*x!18 - 23.027*x!19 + 201.61*x!20 - 171.24*x!21 + 169.57*x!22 - 91.873*x!23 - 44.001*x!24 + 0.050997*x!25 - 0.0039331*x!26 + 0.034116*x!27 + 0.13*x!28 - 0.011071*x!29 - 0.10583*x!30 + 0.26442*x!31 + 0.015922*x!32 - 0.32337*x!33 + 1.3989*x!34 + 0.12598*x!35 - 2.6645*x!36 - 0.3337*x!37 + 0.32621*x!38 - 0.9175*x!39 - 0.18546*x!40 + 0.64555*x!41 + 0.32848*x!42 - 0.024258*x!43 + 0.21239*x!44 - 0.18039*x!45 + 0.17864*x!46 - 0.096784*x!47 - 0.046353*x!48"
definition "x37' x == 16.772*x!2 - 18.711*x!1 + 31.337*x!3 - 86.799*x!4 - 1.8261*x!5 - 326.22*x!6 - 26.875*x!7 + 48.423*x!8 - 1444.1*x!9 - 111.75*x!10 + 580.84*x!11 - 316.97*x!12 - 2618.4*x!13 + 213.69*x!14 - 227.06*x!15 - 1560.3*x!16 - 475.12*x!17 + 287.08*x!18 + 62.345*x!19 + 349.71*x!20 - 307.69*x!21 + 551.86*x!22 - 413.54*x!23 - 278.79*x!24 - 0.019712*x!25 + 0.017669*x!26 + 0.033012*x!27 - 0.091439*x!28 - 0.0019237*x!29 - 0.34366*x!30 - 0.028311*x!31 + 0.051011*x!32 - 1.5212*x!33 - 0.11773*x!34 + 0.61189*x!35 - 0.33391*x!36 - 3.2531*x!37 + 0.22511*x!38 - 0.23919*x!39 - 1.6437*x!40 - 0.50052*x!41 + 0.30242*x!42 + 0.065677*x!43 + 0.36841*x!44 - 0.32414*x!45 + 0.58136*x!46 - 0.43564*x!47 - 0.29369*x!48"
definition "x38' x == 2.1605*x!1 + 59.152*x!2 - 19.397*x!3 + 2.4357*x!4 - 153.32*x!5 + 143.74*x!6 + 5.1672*x!7 + 235.26*x!8 + 606.81*x!9 - 229.22*x!10 + 1225.8*x!11 + 308.88*x!12 + 220.47*x!13 - 2060.7*x!14 - 41.024*x!15 + 847.46*x!16 - 549.36*x!17 + 704.76*x!18 + 575.93*x!19 - 182.76*x!20 + 62.77*x!21 - 246.62*x!22 + 238.45*x!23 + 159.35*x!24 + 0.002276*x!25 + 0.062314*x!26 - 0.020434*x!27 + 0.0025659*x!28 - 0.16151*x!29 + 0.15142*x!30 + 0.0054434*x!31 + 0.24784*x!32 + 0.63924*x!33 - 0.24147*x!34 + 1.2913*x!35 + 0.32539*x!36 + 0.23225*x!37 - 2.6656*x!38 - 0.043217*x!39 + 0.89276*x!40 - 0.57872*x!41 + 0.74243*x!42 + 0.60672*x!43 - 0.19253*x!44 + 0.066125*x!45 - 0.2598*x!46 + 0.25119*x!47 + 0.16786*x!48"
definition "x39' x == 11.65*x!2 - 11.108*x!1 + 6.8996*x!3 + 10.745*x!4 - 14.165*x!5 - 24.224*x!6 + 58.6*x!7 + 1.0473*x!8 - 23.411*x!9 + 194.71*x!10 + 124.74*x!11 - 874.49*x!12 - 232.17*x!13 - 36.538*x!14 - 982.44*x!15 - 164.62*x!16 + 658.46*x!17 + 612.29*x!18 + 81.858*x!19 + 340.63*x!20 - 202.91*x!21 + 81.196*x!22 - 56.024*x!23 - 15.279*x!24 - 0.011702*x!25 + 0.012273*x!26 + 0.0072684*x!27 + 0.01132*x!28 - 0.014922*x!29 - 0.025519*x!30 + 0.061732*x!31 + 0.0011033*x!32 - 0.024662*x!33 + 0.20512*x!34 + 0.1314*x!35 - 0.92123*x!36 - 0.24458*x!37 - 0.038491*x!38 - 1.5297*x!39 - 0.17342*x!40 + 0.69366*x!41 + 0.64502*x!42 + 0.086233*x!43 + 0.35883*x!44 - 0.21375*x!45 + 0.085536*x!46 - 0.059019*x!47 - 0.016096*x!48"
definition "x40' x == 0.34677*x!2 - 45.16*x!1 + 87.266*x!3 - 58.989*x!4 + 81.86*x!5 - 393.99*x!6 - 43.617*x!7 - 87.105*x!8 - 585.65*x!9 - 95.775*x!10 - 55.621*x!11 - 175.4*x!12 - 1550.2*x!13 + 849.01*x!14 - 150.24*x!15 - 2831.0*x!16 - 714.73*x!17 - 306.41*x!18 - 276.74*x!19 + 1235.6*x!20 - 213.26*x!21 + 900.37*x!22 - 708.02*x!23 - 408.51*x!24 - 0.047574*x!25 + 0.00036531*x!26 + 0.09193*x!27 - 0.062142*x!28 + 0.086236*x!29 - 0.41505*x!30 - 0.045948*x!31 - 0.091761*x!32 - 0.61696*x!33 - 0.10089*x!34 - 0.058594*x!35 - 0.18478*x!36 - 1.633*x!37 + 0.89439*x!38 - 0.15827*x!39 - 3.477*x!40 - 0.75293*x!41 - 0.32279*x!42 - 0.29153*x!43 + 1.3016*x!44 - 0.22465*x!45 + 0.94849*x!46 - 0.74586*x!47 - 0.43035*x!48"
definition "x41' x == 3.5059*x!1 - 19.002*x!2 + 24.585*x!3 - 17.341*x!4 + 25.7*x!5 - 100.44*x!6 - 121.83*x!7 + 37.286*x!8 - 153.78*x!9 - 417.65*x!10 + 181.1*x!11 + 615.65*x!12 - 480.91*x!13 - 550.2*x!14 + 663.43*x!15 - 703.07*x!16 - 2922.4*x!17 - 629.58*x!18 + 982.78*x!19 - 72.585*x!20 + 517.72*x!21 + 573.36*x!22 - 34.103*x!23 - 92.294*x!24 + 0.0036933*x!25 - 0.020017*x!26 + 0.025899*x!27 - 0.018268*x!28 + 0.027073*x!29 - 0.1058*x!30 - 0.12834*x!31 + 0.039279*x!32 - 0.162*x!33 - 0.43998*x!34 + 0.19078*x!35 + 0.64856*x!36 - 0.50662*x!37 - 0.57961*x!38 + 0.69889*x!39 - 0.74065*x!40 - 3.5734*x!41 - 0.66323*x!42 + 1.0353*x!43 - 0.076465*x!44 + 0.54539*x!45 + 0.60401*x!46 - 0.035926*x!47 - 0.097227*x!48"
definition "x42' x == 11.689*x!2 - 6.541*x!1 + 14.446*x!3 - 16.841*x!4 + 27.253*x!5 - 50.506*x!6 - 63.95*x!7 - 102.32*x!8 - 140.13*x!9 - 204.16*x!10 - 309.41*x!11 + 316.39*x!12 + 287.25*x!13 + 700.16*x!14 + 615.11*x!15 - 292.97*x!16 - 628.33*x!17 - 1965.7*x!18 - 1181.8*x!19 - 160.14*x!20 + 504.08*x!21 + 10.684*x!22 - 328.24*x!23 - 67.729*x!24 - 0.0068906*x!25 + 0.012313*x!26 + 0.015219*x!27 - 0.017741*x!28 + 0.028709*x!29 - 0.053205*x!30 - 0.067368*x!31 - 0.10779*x!32 - 0.14762*x!33 - 0.21507*x!34 - 0.32595*x!35 + 0.33331*x!36 + 0.3026*x!37 + 0.73758*x!38 + 0.64799*x!39 - 0.30863*x!40 - 0.66191*x!41 - 2.5655*x!42 - 1.245*x!43 - 0.16869*x!44 + 0.53103*x!45 + 0.011255*x!46 - 0.34578*x!47 - 0.071349*x!48"
definition "x43' x == 5.9383*x!2 - 11.411*x!1 + 26.834*x!3 - 15.359*x!4 + 6.1346*x!5 - 51.136*x!6 - 1.6072*x!7 - 127.63*x!8 - 64.662*x!9 + 76.069*x!10 - 444.22*x!11 - 20.062*x!12 + 77.799*x!13 + 570.73*x!14 + 84.558*x!15 - 263.82*x!16 + 983.07*x!17 - 1184.4*x!18 - 2653.4*x!19 + 240.05*x!20 + 17.029*x!21 - 433.29*x!22 - 721.56*x!23 - 85.171*x!24 - 0.012021*x!25 + 0.0062557*x!26 + 0.028268*x!27 - 0.01618*x!28 + 0.0064625*x!29 - 0.05387*x!30 - 0.0016931*x!31 - 0.13445*x!32 - 0.068118*x!33 + 0.080135*x!34 - 0.46796*x!35 - 0.021135*x!36 + 0.081958*x!37 + 0.60124*x!38 + 0.089078*x!39 - 0.27792*x!40 + 1.0356*x!41 - 1.2477*x!42 - 3.2899*x!43 + 0.25288*x!44 + 0.017939*x!45 - 0.45645*x!46 - 0.76013*x!47 - 0.089724*x!48"
definition "x44' x == 10.661*x!1 + 0.75629*x!2 - 31.37*x!3 + 18.757*x!4 - 29.414*x!5 + 193.91*x!6 - 34.395*x!7 + 32.908*x!8 + 271.89*x!9 - 54.429*x!10 - 33.158*x!11 + 199.94*x!12 + 354.88*x!13 - 181.87*x!14 + 333.88*x!15 + 1248.3*x!16 - 59.084*x!17 - 157.94*x!18 + 239.26*x!19 - 1528.9*x!20 + 772.83*x!21 - 858.92*x!22 + 734.27*x!23 + 372.63*x!24 + 0.011231*x!25 + 0.00079672*x!26 - 0.033047*x!27 + 0.01976*x!28 - 0.030986*x!29 + 0.20427*x!30 - 0.036234*x!31 + 0.034667*x!32 + 0.28643*x!33 - 0.057338*x!34 - 0.03493*x!35 + 0.21063*x!36 + 0.37385*x!37 - 0.19159*x!38 + 0.35173*x!39 + 1.315*x!40 - 0.062242*x!41 - 0.16638*x!42 + 0.25204*x!43 - 2.1053*x!44 + 0.81414*x!45 - 0.90483*x!46 + 0.77352*x!47 + 0.39255*x!48"
definition "x45' x == 21.145*x!1 - 0.67362*x!2 + 25.339*x!3 + 82.664*x!4 - 18.143*x!5 - 108.58*x!6 + 131.04*x!7 + 40.675*x!8 - 205.5*x!9 + 125.37*x!10 + 92.038*x!11 - 169.72*x!12 - 294.36*x!13 + 57.772*x!14 - 200.48*x!15 - 211.37*x!16 + 512.5*x!17 + 500.79*x!18 + 15.006*x!19 + 785.7*x!20 - 3685.6*x!21 + 248.17*x!22 - 125.37*x!23 - 428.07*x!24 + 0.022275*x!25 - 0.00070963*x!26 + 0.026694*x!27 + 0.087083*x!28 - 0.019113*x!29 - 0.11438*x!30 + 0.13805*x!31 + 0.04285*x!32 - 0.21648*x!33 + 0.13207*x!34 + 0.096957*x!35 - 0.17879*x!36 - 0.31009*x!37 + 0.06086*x!38 - 0.2112*x!39 - 0.22266*x!40 + 0.5399*x!41 + 0.52756*x!42 + 0.015808*x!43 + 0.8277*x!44 - 4.3773*x!45 + 0.26143*x!46 - 0.13208*x!47 - 0.45095*x!48"
definition "x46' x == 30.438*x!1 - 10.312*x!2 - 14.559*x!3 + 71.32*x!4 + 9.4074*x!5 + 217.12*x!6 + 3.4082*x!7 - 22.61*x!8 + 366.85*x!9 - 62.437*x!10 - 17.337*x!11 + 170.53*x!12 + 551.59*x!13 - 246.57*x!14 + 70.631*x!15 + 918.77*x!16 + 591.41*x!17 + 17.745*x!18 - 424.27*x!19 - 874.95*x!20 + 255.27*x!21 - 4294.4*x!22 + 510.73*x!23 + 1033.1*x!24 + 0.032064*x!25 - 0.010863*x!26 - 0.015337*x!27 + 0.075133*x!28 + 0.0099102*x!29 + 0.22872*x!30 + 0.0035904*x!31 - 0.023818*x!32 + 0.38646*x!33 - 0.065775*x!34 - 0.018263*x!35 + 0.17964*x!36 + 0.58107*x!37 - 0.25975*x!38 + 0.074406*x!39 + 0.96788*x!40 + 0.62302*x!41 + 0.018694*x!42 - 0.44695*x!43 - 0.92172*x!44 + 0.26891*x!45 - 5.0186*x!46 + 0.53803*x!47 + 1.0883*x!48"
definition "x47' x == 11.835*x!3 - 37.47*x!2 - 18.027*x!1 - 25.981*x!4 + 110.26*x!5 - 133.09*x!6 - 21.113*x!7 - 89.428*x!8 - 265.96*x!9 + 11.486*x!10 - 31.545*x!11 - 88.775*x!12 - 389.13*x!13 + 228.95*x!14 - 47.085*x!15 - 703.45*x!16 - 45.639*x!17 - 333.53*x!18 - 724.09*x!19 + 748.64*x!20 - 119.88*x!21 + 488.53*x!22 - 3962.5*x!23 - 875.81*x!24 - 0.01899*x!25 - 0.039473*x!26 + 0.012468*x!27 - 0.027369*x!28 + 0.11615*x!29 - 0.1402*x!30 - 0.022242*x!31 - 0.094208*x!32 - 0.28018*x!33 + 0.0121*x!34 - 0.033231*x!35 - 0.093521*x!36 - 0.40993*x!37 + 0.24119*x!38 - 0.049602*x!39 - 0.74105*x!40 - 0.048079*x!41 - 0.35136*x!42 - 0.7628*x!43 + 0.78865*x!44 - 0.12629*x!45 + 0.51464*x!46 - 4.669*x!47 - 0.92262*x!48"
definition "x48' x == 12.708*x!1 + 4.8669*x!2 - 6.4356*x!3 + 9.4963*x!4 + 3.5537*x!5 - 74.352*x!6 + 13.537*x!7 - 16.221*x!8 - 158.43*x!9 + 2.6078*x!10 - 31.934*x!11 - 48.095*x!12 - 252.14*x!13 + 158.72*x!14 - 25.236*x!15 - 416.39*x!16 - 103.09*x!17 - 75.108*x!18 - 90.118*x!19 + 375.82*x!20 - 425.25*x!21 + 1006.8*x!22 - 878.11*x!23 - 4455.6*x!24 + 0.013388*x!25 + 0.0051271*x!26 - 0.0067796*x!27 + 0.010004*x!28 + 0.0037436*x!29 - 0.078327*x!30 + 0.01426*x!31 - 0.017088*x!32 - 0.1669*x!33 + 0.0027471*x!34 - 0.033641*x!35 - 0.050665*x!36 - 0.26562*x!37 + 0.16721*x!38 - 0.026585*x!39 - 0.43865*x!40 - 0.1086*x!41 - 0.079123*x!42 - 0.094935*x!43 + 0.39591*x!44 - 0.44798*x!45 + 1.0606*x!46 - 0.92505*x!47 - 5.1884*x!48"
definition "t'   x == 1"
definition "u1   x == x ! 49"

schematic_goal building_fas:
  "[t' X,  x1' X,  x2' X,  x3' X,  x4' X,  x5' X,  x6' X,  x7' X,  x8' X,  x9' X,
  x10' X, x11' X, x12' X, x13' X, x14' X, x15' X, x16' X, x17' X, x18' X, x19' X,
  x20' X, x21' X, x22' X, x23' X, x24' X, x25' X, x26' X, x27' X, x28' X, x29' X,
  x30' X, x31' X, x32' X, x33' X, x34' X, x35' X, x36' X, x37' X, x38' X, x39' X,
  x40' X, x41' X, x42' X, x43' X, x44' X, x45' X, x46' X, x47' X, x48' X, u1 X] =
  interpret_floatariths ?fas X"
  unfolding t'_def x1'_def  x2'_def  x3'_def  x4'_def  x5'_def  x6'_def  x7'_def  x8'_def  x9'_def
    x10'_def x11'_def x12'_def x13'_def x14'_def x15'_def x16'_def x17'_def x18'_def x19'_def
    x20'_def x21'_def x22'_def x23'_def x24'_def x25'_def x26'_def x27'_def x28'_def x29'_def
    x30'_def x31'_def x32'_def x33'_def x34'_def x35'_def x36'_def x37'_def x38'_def x39'_def
    x40'_def x41'_def x42'_def x43'_def x44'_def x45'_def x46'_def x47'_def x48'_def u1_def
  by (reify_floatariths)

concrete_definition building_fas uses building_fas

end

end


theory lemm
imports Main Simdpll
begin
lemma 1[simp]: "resolve [] a = []"
apply simp
done

lemma yes: "findUnit f = Some x \<Longrightarrow> length (filter (notElem x) f) < length f"
proof (induction f)
  case Nil
  then show ?case by simp
next
  case Cons
  fix f a
  assume
    prems: "findUnit (a # f) = Some x" and
    IH: "findUnit f = Some x \<Longrightarrow> length (filter (notElem x) f) < length f"
  then show "length (filter (notElem x) (a # f)) < length (a # f)"
  proof (cases "notElem x a")
    case
      H1: True
    then show ?thesis
    proof (cases "findUnit f = Some x")
      case True
      with IH show ?thesis by simp
    next
      case False
      then show ?thesis by (metis H1 One_nat_def Option.inject findUnit.simps(2) list.sel(1) list.size(3) n_not_Suc_n notElem.elims(2) prems)
qed
next case False
then show ?thesis by (simp add: filter.simps(2) le_imp_less_Suc length_Cons length_filter_le)
qed
qed

lemma ter: "findUnit f = Some x \<Longrightarrow> length (filter (notElem x) f) < length f"
proof (induction f)
  case Nil
  then show ?case by simp
next
  case Cons
  fix f a
  assume
    prems: "findUnit (a # f) = Some x" and
    IH: "findUnit f = Some x \<Longrightarrow> length (filter (notElem x) f) < length f"
  then show "length (filter (notElem x) (a # f)) < length (a # f)"
  proof (cases "notElem x a")
    case
      H1: True
    then show ?thesis
    proof (cases "findUnit f = Some x")
      case True
      with IH show ?thesis by simp
    next
      case False
      then have "Some (hd a) = Some x" "length a = 1"
        using findUnit.simps prems by presburger+
      then have "\<not> notElem x a" by (induction a) simp_all
      with H1 show ?thesis by simp
    qed
  next
    case False
    then show ?thesis by (simp add: le_imp_less_Suc)
  qed
qed

lemma step_1:"f = [] \<Longrightarrow> dpll f = True"
apply auto
done

lemma step_2:"f \<noteq> [] \<Longrightarrow> elem [] f = True \<Longrightarrow> dpll f = False"
apply auto
done

lemma step_3: "\<exists>m. dpll m = True"
using step_1 by blast

lemma step_4: "\<forall>f. f \<noteq> []  \<Longrightarrow>\<exists>m. dpll m = True"
using step_3
apply auto
done

lemma "m = [] \<Longrightarrow> \<exists>f. validModel m  \<and> eval' f m =True"
using eval'.simps(1) validModel.simps(1) by blast

lemma st_1[simp]: "\<forall>f. dpll f = True \<Longrightarrow>  \<exists>m. validModel m  \<and> eval' f m =True"
apply (induction f)
using eval'.simps(1) validModel.simps(1) apply blast
using step_2 by fastforce

lemma st_2[simp]:"\<forall>f.  \<exists>m. validModel m  \<and>  eval' f m =True \<Longrightarrow> dpll f = True"
using eval'.simps(2) evalClause.simps(1) by blast

lemma st_3: "\<forall>f. dpll f = False \<Longrightarrow>  \<exists>m. validModel m =True  \<and> eval' f m =False"
using st_1
using step_1 by blast

lemma st_4[simp]:"\<forall>f. \<exists>m. validModel m =True  \<and> eval' f m =False \<Longrightarrow> dpll f = False"
using st_2
using eval'.simps(1) by blast
end


(*  Title:      HOL/UNITY/Project.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1999  University of Cambridge

Projections of state sets (also of actions and programs).

Inheritance of GUARANTEES properties under extension.
*)

section\<open>Projections of State Sets\<close>

theory Project imports Extend begin

definition projecting :: "['c program => 'c set, 'a*'b => 'c,
                  'a program, 'c program set, 'a program set] => bool" where
    "projecting C h F X' X ==
       \<forall>G. extend h F\<squnion>G \<in> X' --> F\<squnion>project h (C G) G \<in> X"

definition extending :: "['c program => 'c set, 'a*'b => 'c, 'a program,
                 'c program set, 'a program set] => bool" where
    "extending C h F Y' Y ==
       \<forall>G. extend h F  ok G --> F\<squnion>project h (C G) G \<in> Y
              --> extend h F\<squnion>G \<in> Y'"

definition subset_closed :: "'a set set => bool" where
    "subset_closed U == \<forall>A \<in> U. Pow A \<subseteq> U"

context Extend
begin

lemma project_extend_constrains_I:
     "F \<in> A co B ==> project h C (extend h F) \<in> A co B"
apply (auto simp add: extend_act_def project_act_def constrains_def)
done

subsection\<open>Safety\<close>

(*used below to prove Join_project_ensures*)
lemma project_unless:
     "[| G \<in> stable C;  project h C G \<in> A unless B |]
      ==> G \<in> (C \<inter> extend_set h A) unless (extend_set h B)"
apply (simp add: unless_def project_constrains)
apply (blast dest: stable_constrains_Int intro: constrains_weaken)
done

(*Generalizes project_constrains to the program F\<squnion>project h C G
  useful with guarantees reasoning*)
lemma Join_project_constrains:
     "(F\<squnion>project h C G \<in> A co B)  =
        (extend h F\<squnion>G \<in> (C \<inter> extend_set h A) co (extend_set h B) &
         F \<in> A co B)"
apply (simp (no_asm) add: project_constrains)
apply (blast intro: extend_constrains [THEN iffD2, THEN constrains_weaken]
             dest: constrains_imp_subset)
done

(*The condition is required to prove the left-to-right direction
  could weaken it to G \<in> (C \<inter> extend_set h A) co C*)
lemma Join_project_stable:
     "extend h F\<squnion>G \<in> stable C
      ==> (F\<squnion>project h C G \<in> stable A)  =
          (extend h F\<squnion>G \<in> stable (C \<inter> extend_set h A) &
           F \<in> stable A)"
apply (unfold stable_def)
apply (simp only: Join_project_constrains)
apply (blast intro: constrains_weaken dest: constrains_Int)
done

(*For using project_guarantees in particular cases*)
lemma project_constrains_I:
     "extend h F\<squnion>G \<in> extend_set h A co extend_set h B
      ==> F\<squnion>project h C G \<in> A co B"
apply (simp add: project_constrains extend_constrains)
apply (blast intro: constrains_weaken dest: constrains_imp_subset)
done

lemma project_increasing_I:
     "extend h F\<squnion>G \<in> increasing (func o f)
      ==> F\<squnion>project h C G \<in> increasing func"
apply (unfold increasing_def stable_def)
apply (simp del: Join_constrains
            add: project_constrains_I extend_set_eq_Collect)
done

lemma Join_project_increasing:
     "(F\<squnion>project h UNIV G \<in> increasing func)  =
      (extend h F\<squnion>G \<in> increasing (func o f))"
apply (rule iffI)
apply (erule_tac [2] project_increasing_I)
apply (simp del: Join_stable
            add: increasing_def Join_project_stable)
apply (auto simp add: extend_set_eq_Collect extend_stable [THEN iffD1])
done

(*The UNIV argument is essential*)
lemma project_constrains_D:
     "F\<squnion>project h UNIV G \<in> A co B
      ==> extend h F\<squnion>G \<in> extend_set h A co extend_set h B"
by (simp add: project_constrains extend_constrains)

end

subsection\<open>"projecting" and union/intersection (no converses)\<close>

lemma projecting_Int:
     "[| projecting C h F XA' XA;  projecting C h F XB' XB |]
      ==> projecting C h F (XA' \<inter> XB') (XA \<inter> XB)"
by (unfold projecting_def, blast)

lemma projecting_Un:
     "[| projecting C h F XA' XA;  projecting C h F XB' XB |]
      ==> projecting C h F (XA' \<union> XB') (XA \<union> XB)"
by (unfold projecting_def, blast)

lemma projecting_INT:
     "[| !!i. i \<in> I ==> projecting C h F (X' i) (X i) |]
      ==> projecting C h F (\<Inter>i \<in> I. X' i) (\<Inter>i \<in> I. X i)"
by (unfold projecting_def, blast)

lemma projecting_UN:
     "[| !!i. i \<in> I ==> projecting C h F (X' i) (X i) |]
      ==> projecting C h F (\<Union>i \<in> I. X' i) (\<Union>i \<in> I. X i)"
by (unfold projecting_def, blast)

lemma projecting_weaken:
     "[| projecting C h F X' X;  U'<=X';  X \<subseteq> U |] ==> projecting C h F U' U"
by (unfold projecting_def, auto)

lemma projecting_weaken_L:
     "[| projecting C h F X' X;  U'<=X' |] ==> projecting C h F U' X"
by (unfold projecting_def, auto)

lemma extending_Int:
     "[| extending C h F YA' YA;  extending C h F YB' YB |]
      ==> extending C h F (YA' \<inter> YB') (YA \<inter> YB)"
by (unfold extending_def, blast)

lemma extending_Un:
     "[| extending C h F YA' YA;  extending C h F YB' YB |]
      ==> extending C h F (YA' \<union> YB') (YA \<union> YB)"
by (unfold extending_def, blast)

lemma extending_INT:
     "[| !!i. i \<in> I ==> extending C h F (Y' i) (Y i) |]
      ==> extending C h F (\<Inter>i \<in> I. Y' i) (\<Inter>i \<in> I. Y i)"
by (unfold extending_def, blast)

lemma extending_UN:
     "[| !!i. i \<in> I ==> extending C h F (Y' i) (Y i) |]
      ==> extending C h F (\<Union>i \<in> I. Y' i) (\<Union>i \<in> I. Y i)"
by (unfold extending_def, blast)

lemma extending_weaken:
     "[| extending C h F Y' Y;  Y'<=V';  V \<subseteq> Y |] ==> extending C h F V' V"
by (unfold extending_def, auto)

lemma extending_weaken_L:
     "[| extending C h F Y' Y;  Y'<=V' |] ==> extending C h F V' Y"
by (unfold extending_def, auto)

lemma projecting_UNIV: "projecting C h F X' UNIV"
by (simp add: projecting_def)

context Extend
begin

lemma projecting_constrains:
     "projecting C h F (extend_set h A co extend_set h B) (A co B)"
apply (unfold projecting_def)
apply (blast intro: project_constrains_I)
done

lemma projecting_stable:
     "projecting C h F (stable (extend_set h A)) (stable A)"
apply (unfold stable_def)
apply (rule projecting_constrains)
done

lemma projecting_increasing:
     "projecting C h F (increasing (func o f)) (increasing func)"
apply (unfold projecting_def)
apply (blast intro: project_increasing_I)
done

lemma extending_UNIV: "extending C h F UNIV Y"
apply (simp (no_asm) add: extending_def)
done

lemma extending_constrains:
     "extending (%G. UNIV) h F (extend_set h A co extend_set h B) (A co B)"
apply (unfold extending_def)
apply (blast intro: project_constrains_D)
done

lemma extending_stable:
     "extending (%G. UNIV) h F (stable (extend_set h A)) (stable A)"
apply (unfold stable_def)
apply (rule extending_constrains)
done

lemma extending_increasing:
     "extending (%G. UNIV) h F (increasing (func o f)) (increasing func)"
by (force simp only: extending_def Join_project_increasing)

subsection\<open>Reachability and project\<close>

(*In practice, C = reachable(...): the inclusion is equality*)
lemma reachable_imp_reachable_project:
     "[| reachable (extend h F\<squnion>G) \<subseteq> C;
         z \<in> reachable (extend h F\<squnion>G) |]
      ==> f z \<in> reachable (F\<squnion>project h C G)"
apply (erule reachable.induct)
apply (force intro!: reachable.Init simp add: split_extended_all, auto)
 apply (rule_tac act = x in reachable.Acts)
 apply auto
 apply (erule extend_act_D)
apply (rule_tac act1 = "Restrict C act"
       in project_act_I [THEN [3] reachable.Acts], auto)
done

lemma project_Constrains_D:
     "F\<squnion>project h (reachable (extend h F\<squnion>G)) G \<in> A Co B
      ==> extend h F\<squnion>G \<in> (extend_set h A) Co (extend_set h B)"
apply (unfold Constrains_def)
apply (simp del: Join_constrains
            add: Join_project_constrains, clarify)
apply (erule constrains_weaken)
apply (auto intro: reachable_imp_reachable_project)
done

lemma project_Stable_D:
     "F\<squnion>project h (reachable (extend h F\<squnion>G)) G \<in> Stable A
      ==> extend h F\<squnion>G \<in> Stable (extend_set h A)"
apply (unfold Stable_def)
apply (simp (no_asm_simp) add: project_Constrains_D)
done

lemma project_Always_D:
     "F\<squnion>project h (reachable (extend h F\<squnion>G)) G \<in> Always A
      ==> extend h F\<squnion>G \<in> Always (extend_set h A)"
apply (unfold Always_def)
apply (force intro: reachable.Init simp add: project_Stable_D split_extended_all)
done

lemma project_Increasing_D:
     "F\<squnion>project h (reachable (extend h F\<squnion>G)) G \<in> Increasing func
      ==> extend h F\<squnion>G \<in> Increasing (func o f)"
apply (unfold Increasing_def, auto)
apply (subst extend_set_eq_Collect [symmetric])
apply (simp (no_asm_simp) add: project_Stable_D)
done

subsection\<open>Converse results for weak safety: benefits of the argument C\<close>

(*In practice, C = reachable(...): the inclusion is equality*)
lemma reachable_project_imp_reachable:
     "[| C \<subseteq> reachable(extend h F\<squnion>G);
         x \<in> reachable (F\<squnion>project h C G) |]
      ==> \<exists>y. h(x,y) \<in> reachable (extend h F\<squnion>G)"
apply (erule reachable.induct)
apply  (force intro: reachable.Init)
apply (auto simp add: project_act_def)
apply (force del: Id_in_Acts intro: reachable.Acts extend_act_D)+
done

lemma project_set_reachable_extend_eq:
     "project_set h (reachable (extend h F\<squnion>G)) =
      reachable (F\<squnion>project h (reachable (extend h F\<squnion>G)) G)"
by (auto dest: subset_refl [THEN reachable_imp_reachable_project]
               subset_refl [THEN reachable_project_imp_reachable])

(*UNUSED*)
lemma reachable_extend_Join_subset:
     "reachable (extend h F\<squnion>G) \<subseteq> C
      ==> reachable (extend h F\<squnion>G) \<subseteq>
          extend_set h (reachable (F\<squnion>project h C G))"
apply (auto dest: reachable_imp_reachable_project)
done

lemma project_Constrains_I:
     "extend h F\<squnion>G \<in> (extend_set h A) Co (extend_set h B)
      ==> F\<squnion>project h (reachable (extend h F\<squnion>G)) G \<in> A Co B"
apply (unfold Constrains_def)
apply (simp del: Join_constrains
            add: Join_project_constrains extend_set_Int_distrib)
apply (rule conjI)
 prefer 2
 apply (force elim: constrains_weaken_L
              dest!: extend_constrains_project_set
                     subset_refl [THEN reachable_project_imp_reachable])
apply (blast intro: constrains_weaken_L)
done

lemma project_Stable_I:
     "extend h F\<squnion>G \<in> Stable (extend_set h A)
      ==> F\<squnion>project h (reachable (extend h F\<squnion>G)) G \<in> Stable A"
apply (unfold Stable_def)
apply (simp (no_asm_simp) add: project_Constrains_I)
done

lemma project_Always_I:
     "extend h F\<squnion>G \<in> Always (extend_set h A)
      ==> F\<squnion>project h (reachable (extend h F\<squnion>G)) G \<in> Always A"
apply (unfold Always_def)
apply (auto simp add: project_Stable_I)
apply (unfold extend_set_def, blast)
done

lemma project_Increasing_I:
    "extend h F\<squnion>G \<in> Increasing (func o f)
     ==> F\<squnion>project h (reachable (extend h F\<squnion>G)) G \<in> Increasing func"
apply (unfold Increasing_def, auto)
apply (simp (no_asm_simp) add: extend_set_eq_Collect project_Stable_I)
done

lemma project_Constrains:
     "(F\<squnion>project h (reachable (extend h F\<squnion>G)) G \<in> A Co B)  =
      (extend h F\<squnion>G \<in> (extend_set h A) Co (extend_set h B))"
apply (blast intro: project_Constrains_I project_Constrains_D)
done

lemma project_Stable:
     "(F\<squnion>project h (reachable (extend h F\<squnion>G)) G \<in> Stable A)  =
      (extend h F\<squnion>G \<in> Stable (extend_set h A))"
apply (unfold Stable_def)
apply (rule project_Constrains)
done

lemma project_Increasing:
   "(F\<squnion>project h (reachable (extend h F\<squnion>G)) G \<in> Increasing func)  =
    (extend h F\<squnion>G \<in> Increasing (func o f))"
apply (simp (no_asm_simp) add: Increasing_def project_Stable extend_set_eq_Collect)
done

subsection\<open>A lot of redundant theorems: all are proved to facilitate reasoning
    about guarantees.\<close>

lemma projecting_Constrains:
     "projecting (%G. reachable (extend h F\<squnion>G)) h F
                 (extend_set h A Co extend_set h B) (A Co B)"

apply (unfold projecting_def)
apply (blast intro: project_Constrains_I)
done

lemma projecting_Stable:
     "projecting (%G. reachable (extend h F\<squnion>G)) h F
                 (Stable (extend_set h A)) (Stable A)"
apply (unfold Stable_def)
apply (rule projecting_Constrains)
done

lemma projecting_Always:
     "projecting (%G. reachable (extend h F\<squnion>G)) h F
                 (Always (extend_set h A)) (Always A)"
apply (unfold projecting_def)
apply (blast intro: project_Always_I)
done

lemma projecting_Increasing:
     "projecting (%G. reachable (extend h F\<squnion>G)) h F
                 (Increasing (func o f)) (Increasing func)"
apply (unfold projecting_def)
apply (blast intro: project_Increasing_I)
done

lemma extending_Constrains:
     "extending (%G. reachable (extend h F\<squnion>G)) h F
                  (extend_set h A Co extend_set h B) (A Co B)"
apply (unfold extending_def)
apply (blast intro: project_Constrains_D)
done

lemma extending_Stable:
     "extending (%G. reachable (extend h F\<squnion>G)) h F
                  (Stable (extend_set h A)) (Stable A)"
apply (unfold extending_def)
apply (blast intro: project_Stable_D)
done

lemma extending_Always:
     "extending (%G. reachable (extend h F\<squnion>G)) h F
                  (Always (extend_set h A)) (Always A)"
apply (unfold extending_def)
apply (blast intro: project_Always_D)
done

lemma extending_Increasing:
     "extending (%G. reachable (extend h F\<squnion>G)) h F
                  (Increasing (func o f)) (Increasing func)"
apply (unfold extending_def)
apply (blast intro: project_Increasing_D)
done

subsection\<open>leadsETo in the precondition (??)\<close>

subsubsection\<open>transient\<close>

lemma transient_extend_set_imp_project_transient:
     "[| G \<in> transient (C \<inter> extend_set h A);  G \<in> stable C |]
      ==> project h C G \<in> transient (project_set h C \<inter> A)"
apply (auto simp add: transient_def Domain_project_act)
apply (subgoal_tac "act `` (C \<inter> extend_set h A) \<subseteq> - extend_set h A")
 prefer 2
 apply (simp add: stable_def constrains_def, blast)
(*back to main goal*)
apply (erule_tac V = "AA \<subseteq> -C \<union> BB" for AA BB in thin_rl)
apply (drule bspec, assumption)
apply (simp add: extend_set_def project_act_def, blast)
done

(*converse might hold too?*)
lemma project_extend_transient_D:
     "project h C (extend h F) \<in> transient (project_set h C \<inter> D)
      ==> F \<in> transient (project_set h C \<inter> D)"
apply (simp add: transient_def Domain_project_act, safe)
apply blast+
done

subsubsection\<open>ensures -- a primitive combining progress with safety\<close>

(*Used to prove project_leadsETo_I*)
lemma ensures_extend_set_imp_project_ensures:
     "[| extend h F \<in> stable C;  G \<in> stable C;
         extend h F\<squnion>G \<in> A ensures B;  A-B = C \<inter> extend_set h D |]
      ==> F\<squnion>project h C G
            \<in> (project_set h C \<inter> project_set h A) ensures (project_set h B)"
apply (simp add: ensures_def project_constrains extend_transient,
       clarify)
apply (intro conjI)
(*first subgoal*)
apply (blast intro: extend_stable_project_set
                  [THEN stableD, THEN constrains_Int, THEN constrains_weaken]
             dest!: extend_constrains_project_set equalityD1)
(*2nd subgoal*)
apply (erule stableD [THEN constrains_Int, THEN constrains_weaken])
    apply assumption
   apply (simp (no_asm_use) add: extend_set_def)
   apply blast
 apply (simp add: extend_set_Int_distrib extend_set_Un_distrib)
 apply (blast intro!: extend_set_project_set [THEN subsetD], blast)
(*The transient part*)
apply auto
 prefer 2
 apply (force dest!: equalityD1
              intro: transient_extend_set_imp_project_transient
                         [THEN transient_strengthen])
apply (simp (no_asm_use) add: Int_Diff)
apply (force dest!: equalityD1
             intro: transient_extend_set_imp_project_transient
               [THEN project_extend_transient_D, THEN transient_strengthen])
done

text\<open>Transferring a transient property upwards\<close>
lemma project_transient_extend_set:
     "project h C G \<in> transient (project_set h C \<inter> A - B)
      ==> G \<in> transient (C \<inter> extend_set h A - extend_set h B)"
apply (simp add: transient_def project_set_def extend_set_def project_act_def)
apply (elim disjE bexE)
 apply (rule_tac x=Id in bexI)
  apply (blast intro!: rev_bexI )+
done

lemma project_unless2:
     "[| G \<in> stable C;  project h C G \<in> (project_set h C \<inter> A) unless B |]
      ==> G \<in> (C \<inter> extend_set h A) unless (extend_set h B)"
by (auto dest: stable_constrains_Int intro: constrains_weaken
         simp add: unless_def project_constrains Diff_eq Int_assoc
                   Int_extend_set_lemma)

lemma extend_unless:
   "[|extend h F \<in> stable C; F \<in> A unless B|]
    ==> extend h F \<in> C \<inter> extend_set h A unless extend_set h B"
apply (simp add: unless_def stable_def)
apply (drule constrains_Int)
apply (erule extend_constrains [THEN iffD2])
apply (erule constrains_weaken, blast)
apply blast
done

(*Used to prove project_leadsETo_D*)
lemma Join_project_ensures:
     "[| extend h F\<squnion>G \<in> stable C;
         F\<squnion>project h C G \<in> A ensures B |]
      ==> extend h F\<squnion>G \<in> (C \<inter> extend_set h A) ensures (extend_set h B)"
apply (auto simp add: ensures_eq extend_unless project_unless)
apply (blast intro:  extend_transient [THEN iffD2] transient_strengthen)
apply (blast intro: project_transient_extend_set transient_strengthen)
done

text\<open>Lemma useful for both STRONG and WEAK progress, but the transient
    condition's very strong\<close>

(*The strange induction formula allows induction over the leadsTo
  assumption's non-atomic precondition*)
lemma PLD_lemma:
     "[| extend h F\<squnion>G \<in> stable C;
         F\<squnion>project h C G \<in> (project_set h C \<inter> A) leadsTo B |]
      ==> extend h F\<squnion>G \<in>
          C \<inter> extend_set h (project_set h C \<inter> A) leadsTo (extend_set h B)"
apply (erule leadsTo_induct)
  apply (blast intro: Join_project_ensures)
 apply (blast intro: psp_stable2 [THEN leadsTo_weaken_L] leadsTo_Trans)
apply (simp del: UN_simps add: Int_UN_distrib leadsTo_UN extend_set_Union)
done

lemma project_leadsTo_D_lemma:
     "[| extend h F\<squnion>G \<in> stable C;
         F\<squnion>project h C G \<in> (project_set h C \<inter> A) leadsTo B |]
      ==> extend h F\<squnion>G \<in> (C \<inter> extend_set h A) leadsTo (extend_set h B)"
apply (rule PLD_lemma [THEN leadsTo_weaken])
apply (auto simp add: split_extended_all)
done

lemma Join_project_LeadsTo:
     "[| C = (reachable (extend h F\<squnion>G));
         F\<squnion>project h C G \<in> A LeadsTo B |]
      ==> extend h F\<squnion>G \<in> (extend_set h A) LeadsTo (extend_set h B)"
by (simp del: Join_stable    add: LeadsTo_def project_leadsTo_D_lemma
                                  project_set_reachable_extend_eq)

subsection\<open>Towards the theorem \<open>project_Ensures_D\<close>\<close>

lemma project_ensures_D_lemma:
     "[| G \<in> stable ((C \<inter> extend_set h A) - (extend_set h B));
         F\<squnion>project h C G \<in> (project_set h C \<inter> A) ensures B;
         extend h F\<squnion>G \<in> stable C |]
      ==> extend h F\<squnion>G \<in> (C \<inter> extend_set h A) ensures (extend_set h B)"
(*unless*)
apply (auto intro!: project_unless2 [unfolded unless_def]
            intro: project_extend_constrains_I
            simp add: ensures_def)
(*transient*)
(*A G-action cannot occur*)
 prefer 2
 apply (blast intro: project_transient_extend_set)
(*An F-action*)
apply (force elim!: extend_transient [THEN iffD2, THEN transient_strengthen]
             simp add: split_extended_all)
done

lemma project_ensures_D:
     "[| F\<squnion>project h UNIV G \<in> A ensures B;
         G \<in> stable (extend_set h A - extend_set h B) |]
      ==> extend h F\<squnion>G \<in> (extend_set h A) ensures (extend_set h B)"
apply (rule project_ensures_D_lemma [of _ UNIV, elim_format], auto)
done

lemma project_Ensures_D:
     "[| F\<squnion>project h (reachable (extend h F\<squnion>G)) G \<in> A Ensures B;
         G \<in> stable (reachable (extend h F\<squnion>G) \<inter> extend_set h A -
                     extend_set h B) |]
      ==> extend h F\<squnion>G \<in> (extend_set h A) Ensures (extend_set h B)"
apply (unfold Ensures_def)
apply (rule project_ensures_D_lemma [elim_format])
apply (auto simp add: project_set_reachable_extend_eq [symmetric])
done

subsection\<open>Guarantees\<close>

lemma project_act_Restrict_subset_project_act:
     "project_act h (Restrict C act) \<subseteq> project_act h act"
apply (auto simp add: project_act_def)
done

lemma subset_closed_ok_extend_imp_ok_project:
     "[| extend h F ok G; subset_closed (AllowedActs F) |]
      ==> F ok project h C G"
apply (auto simp add: ok_def)
apply (rename_tac act)
apply (drule subsetD, blast)
apply (rule_tac x = "Restrict C  (extend_act h act)" in rev_image_eqI)
apply simp +
apply (cut_tac project_act_Restrict_subset_project_act)
apply (auto simp add: subset_closed_def)
done

(*Weak precondition and postcondition
  Not clear that it has a converse [or that we want one!]*)

(*The raw version; 3rd premise could be weakened by adding the
  precondition extend h F\<squnion>G \<in> X' *)
lemma project_guarantees_raw:
 assumes xguary:  "F \<in> X guarantees Y"
     and closed:  "subset_closed (AllowedActs F)"
     and project: "!!G. extend h F\<squnion>G \<in> X'
                        ==> F\<squnion>project h (C G) G \<in> X"
     and extend:  "!!G. [| F\<squnion>project h (C G) G \<in> Y |]
                        ==> extend h F\<squnion>G \<in> Y'"
 shows "extend h F \<in> X' guarantees Y'"
apply (rule xguary [THEN guaranteesD, THEN extend, THEN guaranteesI])
apply (blast intro: closed subset_closed_ok_extend_imp_ok_project)
apply (erule project)
done

lemma project_guarantees:
     "[| F \<in> X guarantees Y;  subset_closed (AllowedActs F);
         projecting C h F X' X;  extending C h F Y' Y |]
      ==> extend h F \<in> X' guarantees Y'"
apply (rule guaranteesI)
apply (auto simp add: guaranteesD projecting_def extending_def
                      subset_closed_ok_extend_imp_ok_project)
done

(*It seems that neither "guarantees" law can be proved from the other.*)

subsection\<open>guarantees corollaries\<close>

subsubsection\<open>Some could be deleted: the required versions are easy to prove\<close>

lemma extend_guar_increasing:
     "[| F \<in> UNIV guarantees increasing func;
         subset_closed (AllowedActs F) |]
      ==> extend h F \<in> X' guarantees increasing (func o f)"
apply (erule project_guarantees)
apply (rule_tac [3] extending_increasing)
apply (rule_tac [2] projecting_UNIV, auto)
done

lemma extend_guar_Increasing:
     "[| F \<in> UNIV guarantees Increasing func;
         subset_closed (AllowedActs F) |]
      ==> extend h F \<in> X' guarantees Increasing (func o f)"
apply (erule project_guarantees)
apply (rule_tac [3] extending_Increasing)
apply (rule_tac [2] projecting_UNIV, auto)
done

lemma extend_guar_Always:
     "[| F \<in> Always A guarantees Always B;
         subset_closed (AllowedActs F) |]
      ==> extend h F
            \<in> Always(extend_set h A) guarantees Always(extend_set h B)"
apply (erule project_guarantees)
apply (rule_tac [3] extending_Always)
apply (rule_tac [2] projecting_Always, auto)
done

subsubsection\<open>Guarantees with a leadsTo postcondition\<close>

lemma project_leadsTo_D:
     "F\<squnion>project h UNIV G \<in> A leadsTo B
      ==> extend h F\<squnion>G \<in> (extend_set h A) leadsTo (extend_set h B)"
apply (rule_tac C1 = UNIV in project_leadsTo_D_lemma [THEN leadsTo_weaken], auto)
done

lemma project_LeadsTo_D:
     "F\<squnion>project h (reachable (extend h F\<squnion>G)) G \<in> A LeadsTo B
       ==> extend h F\<squnion>G \<in> (extend_set h A) LeadsTo (extend_set h B)"
apply (rule refl [THEN Join_project_LeadsTo], auto)
done

lemma extending_leadsTo:
     "extending (%G. UNIV) h F
                (extend_set h A leadsTo extend_set h B) (A leadsTo B)"
apply (unfold extending_def)
apply (blast intro: project_leadsTo_D)
done

lemma extending_LeadsTo:
     "extending (%G. reachable (extend h F\<squnion>G)) h F
                (extend_set h A LeadsTo extend_set h B) (A LeadsTo B)"
apply (unfold extending_def)
apply (blast intro: project_LeadsTo_D)
done

end

end


(*
Title: Modal Kleene Algebra with Converse
Author: Cameron Calk, Georg Struth
Maintainer: Georg Struth <g.struth at sheffield.ac.uk>
*)

section \<open>Modal Kleene algebra with Converse\<close>

theory "MKA_conv"
  imports MKA_light KA_conv

begin

text \<open>Here we mainly study the interaction of converse with domain and codomain.\<close>

subsection \<open>Involutive modal Kleene algebras\<close>

class involutive_domain_semiring = domain_semiring + involutive_dioid

begin

lemma "dom ((dom x)\<^sup>\<circ>) = dom x"
  nitpick (* 4-element counterexample *)
  oops

lemma "(dom x = x) = (x = dom (x\<^sup>\<circ>  ))"
  nitpick  (* 4-element counterexample *)
  oops

lemma strong_conv_conv: "dom x \<le> x \<cdot> x\<^sup>\<circ> \<Longrightarrow> x \<le> x \<cdot> x\<^sup>\<circ> \<cdot> x"
proof-
  assume h: "dom x \<le> x \<cdot> x\<^sup>\<circ>"
  have "x = dom x \<cdot> x"
    by simp
  also have "\<dots> \<le>  x \<cdot> x\<^sup>\<circ> \<cdot> x"
    using h local.mult_isor by presburger
  finally show ?thesis.
qed

end

class involutive_modal_semiring  = modal_semiring + involutive_dioid

begin

lemma "dom (x\<^sup>\<circ>) = cod x"
  nitpick (* 4-element counterexample *)
  oops

lemma "(dom x)\<^sup>\<circ> = dom x"
  nitpick (* 4-element counterexample *)
  oops

lemma "(cod x)\<^sup>\<circ> = cod x"
  nitpick (* 4-element counterexample *)
  oops

lemma "dom (x\<^sup>\<circ>) = cod x \<Longrightarrow> cod (x\<^sup>\<circ>) = dom x \<Longrightarrow> (dom x)\<^sup>\<circ> = dom x"
  nitpick (* 5-element counterexample *)
  oops

end

class involutive_modal_kleene_algebra = involutive_modal_semiring + kleene_algebra

subsection \<open>Modal Kleene algebras with converse\<close>

class modal_semiring_converse = modal_semiring + dioid_converse

begin

lemma d_conv [simp]: "(dom x)\<^sup>\<circ> = dom x"
proof-
  have "dom x \<le> dom x \<cdot> (dom x)\<^sup>\<circ> \<cdot> dom x"
    by (simp add: local.strong_gelfand)
  also have  "\<dots> \<le> 1 \<cdot> (dom x)\<^sup>\<circ> \<cdot> 1"
    using local.d_subid local.dd.mult_iso by blast
  finally have a: "dom x \<le> (dom x)\<^sup>\<circ>"
    by simp
  hence "(dom x)\<^sup>\<circ> \<le> dom x"
    by (simp add: local.inv_adj)
  thus ?thesis
    using a by auto
qed

lemma cod_conv: "(cod x)\<^sup>\<circ> = cod x"
  by (metis d_conv local.dc_compat)

lemma d_conv_cod [simp]: "dom (x\<^sup>\<circ>) = cod x"
proof-
  have "dom (x\<^sup>\<circ>) = dom ((x \<cdot> cod x)\<^sup>\<circ>)"
    by simp
  also have "\<dots> = dom ((cod x)\<^sup>\<circ> \<cdot> x\<^sup>\<circ>)"
    using local.inv_contrav by presburger
  also have "\<dots> = dom (cod x \<cdot> x\<^sup>\<circ>)"
    by (simp add: cod_conv)
  also have "\<dots> = dom (dom (cod x) \<cdot> x\<^sup>\<circ>)"
    by simp
  also have "\<dots> = dom (cod x) \<cdot> dom (x\<^sup>\<circ>)"
    using local.d_export by blast
  also have "\<dots> = cod x \<cdot> dom (x\<^sup>\<circ>)"
    by simp
  also have "\<dots> = cod x \<cdot> cod (dom (x\<^sup>\<circ>))"
    by simp
  also have "\<dots> = cod (x \<cdot> cod (dom (x\<^sup>\<circ>)))"
    using local.coddual.d_export by presburger
  also have "\<dots> = cod (x \<cdot> dom (x\<^sup>\<circ>))"
    by simp
  also have "\<dots> = cod ((x\<^sup>\<circ>)\<^sup>\<circ> \<cdot> (dom (x\<^sup>\<circ>))\<^sup>\<circ>)"
    by simp
  also have "\<dots> = cod ((dom (x\<^sup>\<circ>) \<cdot> x\<^sup>\<circ>)\<^sup>\<circ>)"
    using local.inv_contrav by presburger
  also have "\<dots> = cod ((x\<^sup>\<circ>)\<^sup>\<circ>)"
    by simp
  also have "\<dots> = cod x"
    by simp
  finally show ?thesis.
qed

lemma cod_conv_d: "cod (x\<^sup>\<circ>) = dom x"
  by (metis d_conv_cod local.inv_invol)

lemma "dom y = y \<Longrightarrow> fdia (x\<^sup>\<circ>) y = bdia x y"
proof-
  assume h: "dom y = y"
  have "fdia (x\<^sup>\<circ>) y = dom (x\<^sup>\<circ> \<cdot> dom y)"
    by (simp add: local.fdia_def)
  also have "\<dots> = dom ((dom y \<cdot> x)\<^sup>\<circ>)"
    by simp
  also have "\<dots> = cod (dom y \<cdot> x)"
    using d_conv_cod by blast
  also have "\<dots> = bdia x y"
    by (simp add: h local.coddual.fdia_def)
  finally show ?thesis.
qed

lemma "dom y = y \<Longrightarrow> bdia (x\<^sup>\<circ>) y = fdia x y"
  by (metis cod_conv_d d_conv local.coddual.fdia_def local.fdia_def local.inv_contrav)

lemma "dom x \<le> x \<cdot> x\<^sup>\<circ>"
  nitpick (* 3-element counterexample *)
  oops

end

class modal_kleene_algebra_converse = modal_semiring_converse + kleene_algebra

class modal_semiring_strong_converse = involutive_modal_semiring +
  assumes weak_dom_def: "dom x \<le> x \<cdot> x\<^sup>\<circ>"
  and weak_cod_def: "cod x \<le> x\<^sup>\<circ> \<cdot> x"

subclass (in modal_semiring_strong_converse) modal_semiring_converse
  by (unfold_locales, metis local.coddual.d_absorb_eq local.dd.mult_assoc local.mult_isol local.weak_cod_def)

class modal_kleene_algebra_strong_converse = modal_semiring_strong_converse + kleene_algebra

end


section \<open>Zipping Sequences\<close>

theory Sequence_Zip
imports "Sequence_LTL"
begin

  subsection \<open>Zipping Lists\<close>

  notation zip (infixr "||" 51)

  lemmas [simp] = zip_map_fst_snd

  lemma split_zip[no_atp]: "(\<And> x. PROP P x) \<equiv> (\<And> y z. length y = length z \<Longrightarrow> PROP P (y || z))"
  proof
    fix y z
    assume 1: "\<And> x. PROP P x"
    show "PROP P (y || z)" using 1 by this
  next
    fix x :: "('a \<times> 'b) list"
    assume 1: "\<And> y z. length y = length z \<Longrightarrow> PROP P (y || z)"
    have 2: "length (map fst x) = length (map snd x)" by simp
    have 3: "PROP P (map fst x || map snd x)" using 1 2 by this
    show "PROP P x" using 3 by simp
  qed
  lemma split_zip_all[no_atp]: "(\<forall> x. P x) \<longleftrightarrow> (\<forall> y z. length y = length z \<longrightarrow> P (y || z))"
    by (fastforce iff: split_zip)
  lemma split_zip_ex[no_atp]: "(\<exists> x. P x) \<longleftrightarrow> (\<exists> y z. length y = length z \<and> P (y || z))"
    by (fastforce iff: split_zip)

  lemma zip_eq[iff]:
    assumes "length u = length v" "length r = length s"
    shows "u || v = r || s \<longleftrightarrow> u = r \<and> v = s"
    using assms zip_eq_conv by metis

  lemma list_rel_pred_zip: "list_all2 P xs ys \<longleftrightarrow> length xs = length ys \<and> list_all (case_prod P) (xs || ys)"
    unfolding list_all2_conv_all_nth list_all_length by auto

  lemma list_choice_zip: "list_all (\<lambda> x. \<exists> y. P x y) xs \<longleftrightarrow>
    (\<exists> ys. length ys = length xs \<and> list_all (case_prod P) (xs || ys))"
    unfolding list_choice list_rel_pred_zip by metis
  lemma list_choice_pair: "list_all (\<lambda> xy. case_prod (\<lambda> x y. \<exists> z. P x y z) xy) (xs || ys) \<longleftrightarrow>
    (\<exists> zs. length zs = min (length xs) (length ys) \<and> list_all (\<lambda> (x, y, z). P x y z) (xs || ys || zs))"
  proof -
    have 1: "list_all (\<lambda> (xy, z). case xy of (x, y) \<Rightarrow> P x y z) ((xs || ys) || zs) \<longleftrightarrow>
      list_all (\<lambda> (x, y, z). P x y z) (xs || ys || zs)" for zs
      unfolding zip_assoc list.pred_map by (auto intro!: list.pred_cong)
    have 2: "(\<lambda> (x, y). \<exists> z. P x y z) = (\<lambda> xy. \<exists> z. case xy of (x, y) \<Rightarrow> P x y z)" by auto
    show ?thesis unfolding list_choice_zip 1 2 by force
  qed

  lemma list_rel_zip[iff]:
    assumes "length u = length v" "length r = length s"
    shows "list_all2 (rel_prod A B) (u || v) (r || s) \<longleftrightarrow> list_all2 A u r \<and> list_all2 B v s"
  proof safe
    assume [transfer_rule]: "list_all2 (rel_prod A B) (u || v) (r || s)"
    have "list_all2 A (map fst (u || v)) (map fst (r || s))" by transfer_prover
    then show "list_all2 A u r" using assms by simp
    have "list_all2 B (map snd (u || v)) (map snd (r || s))" by transfer_prover
    then show "list_all2 B v s" using assms by simp
  next
    assume [transfer_rule]: "list_all2 A u r" "list_all2 B v s"
    show "list_all2 (rel_prod A B) (u || v) (r || s)" by transfer_prover
  qed

  lemma zip_last[simp]:
    assumes "xs || ys \<noteq> []" "length xs = length ys"
    shows "last (xs || ys) = (last xs, last ys)"
  proof -
    have 1: "xs \<noteq> []" "ys \<noteq> []" using assms(1) by auto
    have "last (xs || ys) = (xs || ys) ! (length (xs || ys) - 1)" using last_conv_nth assms by blast
    also have "\<dots> = (xs ! (length (xs || ys) - 1), ys ! (length (xs || ys) - 1))" using assms 1 by simp
    also have "\<dots> = (xs ! (length xs - 1), ys ! (length ys - 1))" using assms(2) by simp
    also have "\<dots> = (last xs, last ys)" using last_conv_nth 1 by metis
    finally show ?thesis by this
  qed

  subsection \<open>Zipping Streams\<close>

  notation szip (infixr "|||" 51)

  lemmas [simp] = szip_unfold

  lemma smap_szip_same: "smap f (xs ||| xs) = smap (\<lambda> x. f (x, x)) xs" by (coinduction arbitrary: xs) (auto)

  lemma szip_smap[simp]: "smap fst zs ||| smap snd zs = zs" by (coinduction arbitrary: zs) (auto)

  lemma szip_smap_both: "smap f xs ||| smap g ys = smap (map_prod f g) (xs ||| ys)" by (coinduction arbitrary: xs ys) (auto)
  lemma szip_smap_left: "smap f xs ||| ys = smap (apfst f) (xs ||| ys)" by (coinduction arbitrary: xs ys) (auto)
  lemma szip_smap_right: "xs ||| smap f ys = smap (apsnd f) (xs ||| ys)" by (coinduction arbitrary: xs ys) (auto)
  lemmas szip_smap_fold = szip_smap_both szip_smap_left szip_smap_right

  lemma szip_sconst_smap_fst: "sconst a ||| xs = smap (Pair a) xs"
    by (coinduction arbitrary: xs) (auto)
  lemma szip_sconst_smap_snd: "xs ||| sconst a = smap (prod.swap \<circ> Pair a) xs"
    by (coinduction arbitrary: xs) (auto)

  lemma split_szip[no_atp]: "(\<And> x. PROP P x) \<equiv> (\<And> y z. PROP P (y ||| z))"
  proof
    fix y z
    assume 1: "\<And> x. PROP P x"
    show "PROP P (y ||| z)" using 1 by this
  next
    fix x
    assume 1: "\<And> y z. PROP P (y ||| z)"
    have 2: "PROP P (smap fst x ||| smap snd x)" using 1 by this
    show "PROP P x" using 2 by simp
  qed
  lemma split_szip_all[no_atp]: "(\<forall> x. P x) \<longleftrightarrow> (\<forall> y z. P (y ||| z))" by (fastforce iff: split_szip)
  lemma split_szip_ex[no_atp]: "(\<exists> x. P x) \<longleftrightarrow> (\<exists> y z. P (y ||| z))" by (fastforce iff: split_szip)

  lemma szip_eq[iff]: "u ||| v = r ||| s \<longleftrightarrow> u = r \<and> v = s"
    using szip_smap_fst szip_smap_snd by metis

  lemma stream_rel_szip[iff]:
    "stream_all2 (rel_prod A B) (u ||| v) (r ||| s) \<longleftrightarrow> stream_all2 A u r \<and> stream_all2 B v s"
  proof safe
    assume [transfer_rule]: "stream_all2 (rel_prod A B) (u ||| v) (r ||| s)"
    have "stream_all2 A (smap fst (u ||| v)) (smap fst (r ||| s))" by transfer_prover
    then show "stream_all2 A u r" by simp
    have "stream_all2 B (smap snd (u ||| v)) (smap snd (r ||| s))" by transfer_prover
    then show "stream_all2 B v s" by simp
  next
    assume [transfer_rule]: "stream_all2 A u r" "stream_all2 B v s"
    show "stream_all2 (rel_prod A B) (u ||| v) (r ||| s)" by transfer_prover
  qed

  lemma szip_shift[simp]:
    assumes "length u = length s"
    shows "u @- v ||| s @- t = (u || s) @- (v ||| t)"
    using assms by (simp add: eq_shift stake_shift sdrop_shift)

  lemma szip_sset_fst[simp]: "fst ` sset (u ||| v) = sset u" by (metis stream.set_map szip_smap_fst)
  lemma szip_sset_snd[simp]: "snd ` sset (u ||| v) = sset v" by (metis stream.set_map szip_smap_snd)
  lemma szip_sset_elim[elim]:
    assumes "(a, b) \<in> sset (u ||| v)"
    obtains "a \<in> sset u" "b \<in> sset v"
    using assms by (metis image_eqI fst_conv snd_conv szip_sset_fst szip_sset_snd)
  lemma szip_sset[simp]: "sset (u ||| v) \<subseteq> sset u \<times> sset v" by auto

  lemma sset_szip_finite[iff]: "finite (sset (u ||| v)) \<longleftrightarrow> finite (sset u) \<and> finite (sset v)"
  proof safe
    assume 1: "finite (sset (u ||| v))"
    have 2: "finite (fst ` sset (u ||| v))" using 1 by blast
    have 3: "finite (snd ` sset (u ||| v))" using 1 by blast
    show "finite (sset u)" using 2 by simp
    show "finite (sset v)" using 3 by simp
  next
    assume 1: "finite (sset u)" "finite (sset v)"
    have "sset (u ||| v) \<subseteq> sset u \<times> sset v" by simp
    also have "finite \<dots>" using 1 by simp
    finally show "finite (sset (u ||| v))" by this
  qed

  lemma infs_szip_fst[iff]: "infs (P \<circ> fst) (u ||| v) \<longleftrightarrow> infs P u"
  proof -
    have "infs (P \<circ> fst) (u ||| v) \<longleftrightarrow> infs P (smap fst (u ||| v))"
      by (simp add: comp_def del: szip_smap_fst)
    also have "\<dots> \<longleftrightarrow> infs P u" by simp
    finally show ?thesis by this
  qed
  lemma infs_szip_snd[iff]: "infs (P \<circ> snd) (u ||| v) \<longleftrightarrow> infs P v"
  proof -
    have "infs (P \<circ> snd) (u ||| v) \<longleftrightarrow> infs P (smap snd (u ||| v))"
      by (simp add: comp_def del: szip_smap_snd)
    also have "\<dots> \<longleftrightarrow> infs P v" by simp
    finally show ?thesis by this
  qed

end


theory Llist_of_stream_map
  imports Main "$HIPSTER_HOME/IsaHipster"
    Lmap
    Smap
    Stream_of_llist_of_stream
begin
setup Tactic_Data.set_coinduct_sledgehammer
setup Misc_Data.set_noisy
(*cohipster llist_of_stream lmap smap*)
(* ca 70 sec *)

(* Why is this stl z and not just z? *)
lemma lemma_ac [thy_expl]: "llist_of_stream (smap y (stl z)) = lmap y (llist_of_stream (stl z))"
  by (coinduction arbitrary: y z rule: Llist.Llist.coinduct_strong)
    (smt Llist.case_eq_if Lmap.lemma_ab llist_of_stream.disc_iff llist_of_stream.simps(2) llist_of_stream.simps(3) lmap.disc_iff(2) lmap.sel(1) smap.simps(1) smap.simps(2))

lemma lemma_ad [thy_expl]: "llist_of_stream (SCons y (smap z x2)) =
LCons y (lmap z (llist_of_stream x2))"
  by (coinduction arbitrary: x2 y z rule: Llist.Llist.coinduct_strong)
    (smt Llist.distinct(1) Llist.sel(1) Llist.sel(3) Lmap.lemma_aa Stream.sel(1) Stream.sel(2) llist_of_stream.code lnull_def smap.code)

lemma lemma_ae [thy_expl]: "llist_of_stream (smap y (SCons z x2)) =
lmap y (LCons z (llist_of_stream x2))"
  by (coinduction arbitrary: x2 y z rule: Llist.Llist.coinduct_strong)
    (metis (no_types, lifting) Lmap.lemma_aa Stream.sel(1) Stream.sel(2) lemma_ac llist_of_stream.code smap.simps(1) smap.simps(2))

lemma lemma_af [thy_expl]: "llist_of_stream (smap y (smap z x2)) = lmap y (lmap z (llist_of_stream x2))"
  by (coinduction arbitrary: x2 y z rule: Llist.Llist.coinduct_strong)
    (metis (mono_tags, lifting) Lmap.lemma_aa lemma_ac lemma_ae llist_of_stream.code smap.code)
end


(*  Title:       variants/b_fwdrreps/Aodv_Predicates.thy
    License:     BSD 2-Clause. See LICENSE.
    Author:      Timothy Bourke, Inria
*)

section "Invariant assumptions and properties"

theory B_Aodv_Predicates
imports B_Aodv
begin

text \<open>Definitions for expression assumptions on incoming messages and properties of
      outgoing messages.\<close>

abbreviation not_Pkt :: "msg \<Rightarrow> bool"
where "not_Pkt m \<equiv> case m of Pkt _ _ _ \<Rightarrow> False | _ \<Rightarrow> True"

definition msg_sender :: "msg \<Rightarrow> ip"
where "msg_sender m \<equiv> case m of Rreq _ _ _ _ _ _ _ ipc \<Rightarrow> ipc
                              | Rrep _ _ _ _ ipc \<Rightarrow> ipc
                              | Rerr _ ipc \<Rightarrow> ipc
                              | Pkt _ _ ipc \<Rightarrow> ipc"

lemma msg_sender_simps [simp]:
  "\<And>hops rreqid dip dsn dsk oip osn sip.
                          msg_sender (Rreq hops rreqid dip dsn dsk oip osn sip) = sip"
  "\<And>hops dip dsn oip sip. msg_sender (Rrep hops dip dsn oip sip) = sip"
  "\<And>dests sip.            msg_sender (Rerr dests sip) = sip"
  "\<And>d dip sip.            msg_sender (Pkt d dip sip) = sip"
  unfolding msg_sender_def by simp_all

definition msg_zhops :: "msg \<Rightarrow> bool"
where "msg_zhops m \<equiv> case m of
                                 Rreq hopsc _ dipc _ _ oipc _ sipc \<Rightarrow> hopsc = 0 \<longrightarrow> oipc = sipc
                               | Rrep hopsc dipc _ _ sipc \<Rightarrow> hopsc = 0 \<longrightarrow> dipc = sipc
                               | _ \<Rightarrow> True"

lemma msg_zhops_simps [simp]:
  "\<And>hops rreqid dip dsn dsk oip osn sip.
           msg_zhops (Rreq hops rreqid dip dsn dsk oip osn sip) = (hops = 0 \<longrightarrow> oip = sip)"
  "\<And>hops dip dsn oip sip. msg_zhops (Rrep hops dip dsn oip sip) = (hops = 0 \<longrightarrow> dip = sip)"
  "\<And>dests sip.            msg_zhops (Rerr dests sip)        = True"
  "\<And>d dip.                msg_zhops (Newpkt d dip)          = True"
  "\<And>d dip sip.            msg_zhops (Pkt d dip sip)         = True"
  unfolding msg_zhops_def by simp_all

definition rreq_rrep_sn :: "msg \<Rightarrow> bool"
where "rreq_rrep_sn m \<equiv> case m of Rreq _ _ _ _ _ _ osnc _ \<Rightarrow> osnc \<ge> 1
                                | Rrep _ _ dsnc _ _ \<Rightarrow> dsnc \<ge> 1
                                | _ \<Rightarrow> True"

lemma rreq_rrep_sn_simps [simp]:
  "\<And>hops rreqid dip dsn dsk oip osn sip.
           rreq_rrep_sn (Rreq hops rreqid dip dsn dsk oip osn sip) = (osn \<ge> 1)"
  "\<And>hops dip dsn oip sip. rreq_rrep_sn (Rrep hops dip dsn oip sip) = (dsn \<ge> 1)"
  "\<And>dests sip.            rreq_rrep_sn (Rerr dests sip) = True"
  "\<And>d dip.                rreq_rrep_sn (Newpkt d dip)   = True"
  "\<And>d dip sip.            rreq_rrep_sn (Pkt d dip sip)  = True"
  unfolding rreq_rrep_sn_def by simp_all

definition rreq_rrep_fresh :: "rt \<Rightarrow> msg \<Rightarrow> bool"
where "rreq_rrep_fresh crt m \<equiv> case m of Rreq hopsc _ _ _ _ oipc osnc ipcc \<Rightarrow> (ipcc \<noteq> oipc \<longrightarrow>
                                                oipc\<in>kD(crt) \<and> (sqn crt oipc > osnc
                                                                \<or> (sqn crt oipc = osnc
                                                                   \<and> the (dhops crt oipc) \<le> hopsc
                                                                   \<and> the (flag crt oipc) = val)))
                                | Rrep hopsc dipc dsnc _ ipcc \<Rightarrow> (ipcc \<noteq> dipc \<longrightarrow>
                                                                    dipc\<in>kD(crt)
                                                                  \<and> sqn crt dipc = dsnc
                                                                  \<and> the (dhops crt dipc) = hopsc
                                                                  \<and> the (flag crt dipc) = val)
                                | _ \<Rightarrow> True"

lemma rreq_rrep_fresh [simp]:
  "\<And>hops rreqid dip dsn dsk oip osn sip.
           rreq_rrep_fresh crt (Rreq hops rreqid dip dsn dsk oip osn sip) =
                               (sip \<noteq> oip \<longrightarrow> oip\<in>kD(crt)
                                            \<and> (sqn crt oip > osn
                                               \<or> (sqn crt oip = osn
                                                  \<and> the (dhops crt oip) \<le> hops
                                                  \<and> the (flag crt oip) = val)))"
  "\<And>hops dip dsn oip sip. rreq_rrep_fresh crt (Rrep hops dip dsn oip sip) =
                               (sip \<noteq> dip \<longrightarrow> dip\<in>kD(crt)
                                              \<and> sqn crt dip = dsn
                                              \<and> the (dhops crt dip) = hops
                                              \<and> the (flag crt dip) = val)"
  "\<And>dests sip.            rreq_rrep_fresh crt (Rerr dests sip) = True"
  "\<And>d dip.                rreq_rrep_fresh crt (Newpkt d dip)   = True"
  "\<And>d dip sip.            rreq_rrep_fresh crt (Pkt d dip sip)  = True"
  unfolding rreq_rrep_fresh_def by simp_all

definition rerr_invalid :: "rt \<Rightarrow> msg \<Rightarrow> bool"
where "rerr_invalid crt m \<equiv> case m of Rerr destsc _ \<Rightarrow> (\<forall>ripc\<in>dom(destsc).
                                            (ripc\<in>iD(crt) \<and> the (destsc ripc) = sqn crt ripc))
                                | _ \<Rightarrow> True"

lemma rerr_invalid [simp]:
  "\<And>hops rreqid dip dsn dsk oip osn sip.
                           rerr_invalid crt (Rreq hops rreqid dip dsn dsk oip osn sip) = True"
  "\<And>hops dip dsn oip sip. rerr_invalid crt (Rrep hops dip dsn oip sip) = True"
  "\<And>dests sip.            rerr_invalid crt (Rerr dests sip) = (\<forall>rip\<in>dom(dests).
                                                 rip\<in>iD(crt) \<and> the (dests rip) = sqn crt rip)"
  "\<And>d dip.                rerr_invalid crt (Newpkt d dip)   = True"
  "\<And>d dip sip.            rerr_invalid crt (Pkt d dip sip)  = True"
  unfolding rerr_invalid_def by simp_all

definition
  initmissing :: "(nat \<Rightarrow> state option) \<times> 'a \<Rightarrow> (nat \<Rightarrow> state) \<times> 'a"
where
  "initmissing \<sigma> = (\<lambda>i. case (fst \<sigma>) i of None \<Rightarrow> aodv_init i | Some s \<Rightarrow> s, snd \<sigma>)"

lemma not_in_net_ips_fst_init_missing [simp]:
  assumes "i \<notin> net_ips \<sigma>"
    shows "fst (initmissing (netgmap fst \<sigma>)) i = aodv_init i"
  using assms unfolding initmissing_def by simp

lemma fst_initmissing_netgmap_pair_fst [simp]:
  "fst (initmissing (netgmap (\<lambda>(p, q). (fst (id p), snd (id p), q)) s))
                                               = fst (initmissing (netgmap fst s))"
  unfolding initmissing_def by auto

text \<open>We introduce a streamlined alternative to @{term initmissing} with @{term netgmap}
        to simplify invariant statements and thus facilitate their comprehension and
        presentation.\<close>

lemma fst_initmissing_netgmap_default_aodv_init_netlift:
  "fst (initmissing (netgmap fst s)) = default aodv_init (netlift fst s)"
  unfolding initmissing_def default_def
  by (simp add: fst_netgmap_netlift del: One_nat_def)

definition
  netglobal :: "((nat \<Rightarrow> state) \<Rightarrow> bool) \<Rightarrow> ((state \<times> 'b) \<times> 'c) net_state \<Rightarrow> bool"
where
  "netglobal P \<equiv> (\<lambda>s. P (default aodv_init (netlift fst s)))"

end