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

lemma continuous_on_floatarith_zero[simp]: "continuous_on_floatarith 0"
  by (auto simp: zero_floatarith_def)

lemma continuous_on_floatarith_minus[simp]:
  "continuous_on_floatarith (a - b) \<longleftrightarrow> continuous_on_floatarith a \<and> continuous_on_floatarith b"
  by (auto simp: minus_floatarith_def)

lemma continuous_on_floatarith_uminus[simp]:
  "continuous_on_floatarith (- b) \<longleftrightarrow> continuous_on_floatarith b"
  by (auto simp: uminus_floatarith_def)

lemma continuous_on_floatarith_times[simp]:
  "continuous_on_floatarith (a * b) \<longleftrightarrow> continuous_on_floatarith a \<and> continuous_on_floatarith b"
  by (auto simp: times_floatarith_def)

lemma continuous_on_floatarith_plus[simp]:
  "continuous_on_floatarith (a + b) \<longleftrightarrow> continuous_on_floatarith a \<and> continuous_on_floatarith b"
  by (auto simp: plus_floatarith_def)

lemmas isDERIV_Power_iff[simp]

lemma isFDERIV_Suc: "isFDERIV (Suc n) (d#ds) (f#fs) xs \<longleftrightarrow>
  isFDERIV n ds fs xs \<and> isDERIV d f xs
  \<and> (\<forall>x2 < n. isDERIV d (fs ! x2) xs)
  \<and> (\<forall>x2 < n. isDERIV (ds ! x2) f xs)"
  unfolding isFDERIV_def
  by (auto simp: isFDERIV_def nth_Cons split: nat.splits)

lemma isFDERIV_SucI: "isFDERIV (Suc n) (d#ds) (f#fs) xs"
  if "isFDERIV n ds fs xs" "isDERIV d f xs"
  "\<And>i. i < n \<Longrightarrow> isDERIV d (fs ! i) xs"
  "\<And>i. i < n \<Longrightarrow> isDERIV (ds ! i) f xs"
  using that
  by (auto simp: isFDERIV_Suc)

lemma isFDERIV_0[simp]: "isFDERIV 0 [] [] zs"
  by (auto simp: isFDERIV_def nth_Cons split: nat.splits)

lemmas [simp] = Basis_list_real_def

subsection \<open>Space Rendezvous\<close>

experiment begin

unbundle floatarith_notation

abbreviation "r \<equiv> 42164000"
abbreviation "mu \<equiv> 3.986*10^14*3600"
abbreviation "m_c \<equiv> 500"
abbreviation "n \<equiv> 0.004375293492336"
abbreviation "K1_11 \<equiv> -28.8287"
abbreviation "K1_12 \<equiv> 0.1005"
abbreviation "K1_13 \<equiv> -1449.9754"
abbreviation "K1_14 \<equiv> 0.0046"
abbreviation "K1_21 \<equiv> -0.087"
abbreviation "K1_22 \<equiv> -33.2562"
abbreviation "K1_23 \<equiv> 0.00462"
abbreviation "K1_24 \<equiv> -1451.5013"
abbreviation "K2_11 \<equiv> -288.0288"
abbreviation "K2_12 \<equiv> 0.1312"
abbreviation "K2_13 \<equiv> -9614.9898"
abbreviation "K2_14 \<equiv> 0"
abbreviation "K2_21 \<equiv> -0.1312"
abbreviation "K2_22 \<equiv> -288 "
abbreviation "K2_23 \<equiv> 0"
abbreviation "K2_24 \<equiv> -9614.9883"

subsubsection \<open>Location P1\<close>

schematic_goal p1_fas:
  fixes X
  defines "t \<equiv> X!0"
    and "x \<equiv> X ! 1"
    and "y \<equiv> X ! 2"
    and "vx \<equiv> X ! 3"
    and "vy \<equiv> X ! 4"
  shows
  "[
  \<comment> \<open>t' = \<close> 1,
  \<comment> \<open>x' = \<close> vx,
  \<comment> \<open>y' = \<close> vy,
  \<comment> \<open>vx' = \<close> (n^2 + K1_11/m_c)*x + (2*n + K1_14/m_c) * vy + K1_12/m_c * y + K1_13/m_c * vx + mu/r^2 - mu/sqrt((r+x)^2-y^2)^3 * (r+x),
  \<comment> \<open>vy' = \<close> (n^2 + K1_22/m_c)*y + (K1_23/m_c -2*n) * vx + K1_21/m_c * x + K1_24/m_c * vy - mu/sqrt((r+x)^2-y^2)^3 * y
] = interpret_floatariths ?fas X"
  unfolding t_def x_def y_def vx_def vy_def
  by (reify_floatariths)

concrete_definition p1_fas uses p1_fas

abbreviation "safe_sqrt \<equiv> (Less 0 ((Num r + Var 1)^\<^sub>e2 - (Var 2) ^\<^sub>e 2)) \<comment> \<open>sqrt defined\<close>"

abbreviation "safe_p1 \<equiv> Conj (Less (Var 0) (Num 125)) \<comment> \<open>abort\<close>
  safe_sqrt"

interpretation p1: ode_interpretation safe_p1
  "{(t, x, y, vx, vy). t < 125 \<and> (r+x)^2-y^2 > 0}" p1_fas
   "\<lambda>(t, x, y, vx, vy).
      (1,
       vx,
       vy,
       (n^2 + K1_11/m_c)*x + (2*n + K1_14/m_c) * vy + K1_12/m_c * y + K1_13/m_c * vx + mu/r^2 - mu/sqrt((r+x)^2-y^2)^3 * (r+x),
       (n^2 + K1_22/m_c)*y + (K1_23/m_c -2*n) * vx + K1_21/m_c * x + K1_24/m_c * vy - mu/sqrt((r+x)^2-y^2)^3 * y
  )::real*real*real*real*real"
  "d::5" for d
  by standard
    (auto simp: p1_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 inverse_eq_divide intro!: isFDERIV_I)

lemma poincare_section_rep[poincare_tac_theorems]:
              "{(0, -100, -500, -1000, -1000)..(125, -100, 0, 1000, 1000)::real*real*real*real*real} =
  {eucl_of_list [0, -100, -500, -1000, -1000]..eucl_of_list [125, -100, 0, 1000, 1000]}"
  by (auto simp: eucl_of_list_prod)

abbreviation "p1_ro \<equiv> ro 10 10 7 2 2 2"

lemma p1_ro: "TAG_reach_optns p1_ro" by simp

lemma p1_start: "TAG_sctn False" by simp

lemma p1_pi_0: "p1.guards_invar DIM(real \<times> real \<times> real \<times> real \<times> real) []"
  by (auto simp: p1.guards_invar_def)

lemma
  notes [poincare_tac_theorems] = p1_ro p1_start p1_pi_0
  shows "\<forall>x\<in>{(0, -925, -425, 0, 0) .. (0, -875, -375, 0, 0)}.
  p1.returns_to                {(0, -100, -500, -1000, -1000)..(125, -100, 0, 1000, 1000)} x \<and>
  p1.poincare_map_from_outside {(0, -100, -500, -1000, -1000)..(125, -100, 0, 1000, 1000)} x \<in>
      {(108.5, -100, -35.05, 1.993, 0.6489) ..
       (111.8, -100, -28.42, 2.007, 0.8130)}"
  using [[ode_numerics_trace]]
  by (tactic \<open>poincare_bnds_tac @{thms p1_fas_def} 30 50 20 10 [(1, 2, "0x00007f")]
    (* "out_space_p1.out" *) ""  @{context} 1\<close>)

subsubsection \<open>Location P2\<close>

lemma "tan (rad_of 30) \<in> {147 * 2 powr -8 .. 148 * 2 powr -8}"
  unfolding rad_of_def atLeastAtMost_iff
  by (approximation 15)
abbreviation "Tanl \<equiv> Num (Float 147 (-8))"
abbreviation "Tanu \<equiv> Num (Float 148 (-8))"

abbreviation "safe_p2 \<equiv>
  Conj safe_p1
    (Conj (Less (Max (Var 1 * Tanl) (Var 1 * Tanu)) (Var 2))
      (Less (Max (Var 1 * Tanl)(Var 1 * Tanu)) (-(Var 2)))) \<comment> \<open>line of sight\<close>"

schematic_goal p2_fas:
  fixes X
  defines "t \<equiv> X!0"
    and "x \<equiv> X ! 1"
    and "y \<equiv> X ! 2"
    and "vx \<equiv> X ! 3"
    and "vy \<equiv> X ! 4"
  shows
  "[
  \<comment> \<open>t' = \<close> 1,
  \<comment> \<open>x' = \<close> vx,
  \<comment> \<open>y' = \<close> vy,
  \<comment> \<open>vx' = \<close> (n^2 + K2_11/m_c)*x + (2*n + K2_14/m_c)* vy + K2_12/m_c * y + K2_13/m_c * vx + mu/r^2 - mu/sqrt((r+x)^2-y^2)^3 * (r+x),
  \<comment> \<open>vy' = \<close> (n^2 + K2_22/m_c)*y + (K2_23/m_c -2*n)* vx + K2_21/m_c * x + K2_24/m_c * vy - mu/sqrt((r+x)^2-y^2)^3 * y
] = interpret_floatariths ?fas X"
  unfolding t_def x_def y_def vx_def vy_def
  by (reify_floatariths)

concrete_definition p2_fas uses p2_fas

interpretation p2: ode_interpretation safe_p2
  "{(t, x, y, vx, vy). t < 125 \<and>
    (r+x)^2-y^2 > 0 \<and>
    max (x * 147 * 2 powr -8) (x * 147 * 2 powr -8) < y \<and>
    max (x * 147 * 2 powr -8) (x * 147 * 2 powr -8) < -y
  }" p2_fas
  "\<lambda>(t, x, y, vx, vy).
      (1,
       vx,
       vy,
       (n^2 + K2_11/m_c)*x + (2*n + K2_14/m_c) * vy + K2_12/m_c * y + K2_13/m_c * vx + mu/r^2 - mu/sqrt((r+x)^2-y^2)^3 * (r+x),
       (n^2 + K2_22/m_c)*y + (K2_23/m_c -2*n) * vx + K2_21/m_c * x + K2_24/m_c * vy - mu/sqrt((r+x)^2-y^2)^3 * y
  )::real*real*real*real*real"
  "d::5" for d
  by standard
    (auto simp: p2_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 inverse_eq_divide intro!: isFDERIV_I)

lemma poincare_section2_rep[poincare_tac_theorems]:
  "{(120, -1000, -1000, -1000, -1000)..(120, 1000, 1000, 1000, 1000)::real*real*real*real*real} =
  {eucl_of_list [120, -1000, -1000, -1000, -1000]..eucl_of_list [120, 1000, 1000, 1000, 1000]}"
  by (auto simp: eucl_of_list_prod)

abbreviation "p2_ro \<equiv> ro 10 10 7 10 10 2"

lemma p2_ro: "TAG_reach_optns p2_ro" by simp

lemma p2_start: "TAG_sctn False" by simp

lemma p2_pi_0: "p2.guards_invar DIM(real \<times> real \<times> real \<times> real \<times> real) []"
  by (auto simp: p2.guards_invar_def)

lemma
  notes [poincare_tac_theorems] = p2_ro p2_start p2_pi_0
  shows "\<forall>x\<in>{(108.5, -100, -35.05, 1.993, 0.6489) ..
       (111.8, -100, -28.42, 2.007, 0.8130)}.
  p2.returns_to                {(120, -1000, -1000, -1000, -1000)..(120, 1000, 1000, 1000, 1000)} x \<and>
  p2.poincare_map_from_outside {(120, -1000, -1000, -1000, -1000)..(120, 1000, 1000, 1000, 1000)} x \<in>
    {(120, -78.24, -27.43, 2.125, 0.596) ..
     (120, -70.85, -20.12, 2.348, 0.829)}"
  using [[ode_numerics_trace]]
  by (tactic \<open>poincare_bnds_tac @{thms p2_fas_def} 30 50 20 10 [(1, 2, "0x7f0000"), (3, 4, "0x0000ff")]
    (* "out_space_p2.out" *) ""  @{context} 1\<close>)

(*(1.2e2 -70.8581e1 -2.012131e1 2.347061 8.28834e-1)*)
subsubsection \<open>Location Passive\<close>

schematic_goal passive_fas:
  fixes X
  defines "t \<equiv> X!0"
    and "x \<equiv> X ! 1"
    and "y \<equiv> X ! 2"
    and "vx \<equiv> X ! 3"
    and "vy \<equiv> X ! 4"
  shows
  "[
  \<comment> \<open>t' = \<close> 1,
  \<comment> \<open>x' = \<close> vx,
  \<comment> \<open>y' = \<close> vy,
  \<comment> \<open>vx' = \<close> n^2 * x + 2*n * vy + mu/r^2 - mu/sqrt((r+x)^2-y^2)^3 * (r+x),
  \<comment> \<open>vy' = \<close> n^2*y - 2*n * vx - mu/sqrt((r+x)^2-y^2)^3 * y
] = interpret_floatariths ?fas X"
  unfolding t_def x_def y_def vx_def vy_def
  by (reify_floatariths)

concrete_definition passive_fas uses passive_fas

abbreviation "safe_passive \<equiv> Conj
  safe_sqrt
  (Disj (Disj (Less (Var 1) (Num (-1))) (Less (Num 1) (Var 1)))
    (Disj (Less (Var 2) (Num (-1))) (Less (Num 1) (Var 2))))
    \<comment> \<open>avoiding satellite in box of ``radius'' 1\<close>"

interpretation passive: ode_interpretation safe_passive
  "{(t, x, y, vx, vy). (r+x)^2-y^2 > 0 \<and> (x, y) \<notin> {(-1, -1) .. (1, 1)}}" passive_fas
  "\<lambda>(t, x, y, vx, vy).
      (1,
       vx,
       vy,
       n^2 * x + 2*n * vy + mu/r^2 - mu/sqrt((r+x)^2-y^2)^3 * (r+x),
       n^2*y - 2*n * vx - mu/sqrt((r+x)^2-y^2)^3 * y
  )::real*real*real*real*real"
  "d::5" for d
  by standard
    (auto simp: passive_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 inverse_eq_divide intro!: isFDERIV_I)

lemma poincare_section3_rep[poincare_tac_theorems]:
              "{(200, -1000, -1000, -1000, -1000)..(200, 1000, 1000, 1000, 1000)::real*real*real*real*real} =
  {eucl_of_list [200, -1000, -1000, -1000, -1000]..eucl_of_list [200, 1000, 1000, 1000, 1000]}"
  by (auto simp: eucl_of_list_prod)

abbreviation "passive_ro \<equiv> ro 10 10 7 10 10 2"

lemma passive_ro: "TAG_reach_optns passive_ro" by simp

lemma passive_start: "TAG_sctn False" by simp

lemma passive_pi_0: "passive.guards_invar DIM(real \<times> real \<times> real \<times> real \<times> real) []"
  by (auto simp: passive.guards_invar_def)

lemma
  notes [poincare_tac_theorems] = passive_ro passive_start passive_pi_0
  shows "\<forall>x\<in>{(120, -78.24, -27.43, 2.125, 0.596) ..
     (120, -70.85, -20.12, 2.348, 0.829)}.
  passive.returns_to                {(200, -1000, -1000, -1000, -1000)..(200, 1000, 1000, 1000, 1000)} x \<and>
  passive.poincare_map_from_outside {(200, -1000, -1000, -1000, -1000)..(200, 1000, 1000, 1000, 1000)} x \<in>
    {(200, 89.95, -46.20, 2.047, -1.050) ..
     (200, 123.9, -14.19, 2.460, -0.701)}"
  using [[ode_numerics_trace]]
  by (tactic \<open>poincare_bnds_tac @{thms passive_fas_def} 30 50 20 10 [(1, 2, "0x000000")] (* "out_space_passive.out" *) ""  @{context} 1\<close>)

end

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

unbundle floatarith_notation

abbreviation "g \<equiv> 9.81"
abbreviation "R \<equiv> 0.1"
abbreviation "l \<equiv> 0.5"
abbreviation "M\<^sub>r\<^sub>o\<^sub>t\<^sub>o\<^sub>r \<equiv> 0.1"
abbreviation "M \<equiv> 1"
abbreviation "m \<equiv> M + 4 * M\<^sub>r\<^sub>o\<^sub>t\<^sub>o\<^sub>r"
abbreviation "J\<^sub>x \<equiv> 2/5 * M * R\<^sup>2 + 2 * l\<^sup>2 * M\<^sub>r\<^sub>o\<^sub>t\<^sub>o\<^sub>r"
abbreviation "J\<^sub>y \<equiv> J\<^sub>x"
abbreviation "J\<^sub>z \<equiv> 2/5 * M * R\<^sup>2 + 4 * l\<^sup>2 * M\<^sub>r\<^sub>o\<^sub>t\<^sub>o\<^sub>r"

abbreviation "u x i \<equiv> x ! (i + 12)"
abbreviation "F x \<equiv> m * g - 10 * (x!3 - u x 1) + 3 * x!6"
abbreviation "\<tau>\<^sub>\<phi> x \<equiv> - (x ! 7 - u x 2) - x!10"
abbreviation "\<tau>\<^sub>\<theta> x \<equiv> - (x ! 8 - u x 3) - x!11"
abbreviation "\<tau>\<^sub>\<psi> x \<equiv> 0"

schematic_goal quadrot_fas:
  "[\<comment> \<open>\<open>t:\<close>\<close> 1,
    \<comment> \<open>\<open>x\<^sub>1:\<close>\<close> cos (x!8) * cos (x!9)* x ! 4 + (sin(x!7) * sin(x!8) * cos (x!9) - cos(x!7) * sin(x!9))*x!5
              + (cos(x!7) * sin(x!8) * cos(x!9) + sin(x!7) * sin(x!9)) * x!6,
    \<comment> \<open>\<open>x\<^sub>2:\<close>\<close> cos(x!8) * sin (x!9) * x!4 + (sin(x!7) * sin (x!8) * sin(x!9) + cos(x!7) * cos (x!9))*x!5
              + (cos(x!7) * sin(x!8) * sin(x!9) - sin ( x!7) * cos (x!9)) * x!6,
    \<comment> \<open>\<open>x\<^sub>3:\<close>\<close> sin(x!8) * x!4 - sin(x!7) * cos (x!8) * x!5 - cos(x!7) *cos(x!8)*x!6,
    \<comment> \<open>\<open>x\<^sub>4:\<close>\<close> x!12 * x!5- x!11*x!6 - g * sin(x!8),
    \<comment> \<open>\<open>x\<^sub>5:\<close>\<close> x!10 * x!6 - x!12*x!4 + g * cos(x!8 * sin(x!7)),
    \<comment> \<open>\<open>x\<^sub>6:\<close>\<close> x!11 * x!4 - x!10*x!5 + g * cos(x!8 * cos(x!7)) - F x / m,
    \<comment> \<open>\<open>x\<^sub>7:\<close>\<close> x!10 + (sin(x!7)*tan(x!8))*x!11 + (cos(x!7)*tan(x!8))*x!12,
    \<comment> \<open>\<open>x\<^sub>8:\<close>\<close> cos(x!7) * x!11 - sin(x!7)*x!12,
    \<comment> \<open>\<open>x\<^sub>9:\<close>\<close> sin(x!7) / cos(x!8) * x!11 + cos(x!7)/cos(x!8)*x!12,
    \<comment> \<open>\<open>x\<^sub>1\<^sub>0:\<close>\<close> (J\<^sub>y - J\<^sub>z)/J\<^sub>x*x!11*x!12 + \<tau>\<^sub>\<phi> x / J\<^sub>x,
    \<comment> \<open>\<open>x\<^sub>1\<^sub>1:\<close>\<close> (J\<^sub>z - J\<^sub>x)/J\<^sub>y*x!10*x!12 + \<tau>\<^sub>\<theta> x / J\<^sub>y,
    \<comment> \<open>\<open>x\<^sub>1\<^sub>2:\<close>\<close> (J\<^sub>x - J\<^sub>y)/J\<^sub>z*x!10*x!11 + \<tau>\<^sub>\<psi> x / J\<^sub>z,
    \<comment> \<open>\<open>u\<^sub>1:\<close>\<close> 0,
    \<comment> \<open>\<open>u\<^sub>2:\<close>\<close> 0,
    \<comment> \<open>\<open>u\<^sub>3:\<close>\<close> 0]
  = interpret_floatariths ?fas x"
  by (reify_floatariths)
concrete_definition quadrot_fas uses quadrot_fas

abbreviation "Fr x3 x6 u1 \<equiv> m * g - 10 * (x3 - u1) + 3 * x6"

lemma isDERIV_Power_if[simp]:
  "isDERIV x (f ^\<^sub>e n) vs = (if n = 0 then True else isDERIV x f vs)"
  by (cases n) auto

definition "Ne x y = Disj (Less x y) (Less y x)"

lemma Basis_list_16:
  "(Basis_list::(real*real*real*real*real*real*real*real*real*real*real*real*real*real*real*real) list) =
  [
  (1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0),
  (0,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0),
  (0,0,1,0,0,0,0,0,0,0,0,0,0,0,0,0),
  (0,0,0,1,0,0,0,0,0,0,0,0,0,0,0,0),
  (0,0,0,0,1,0,0,0,0,0,0,0,0,0,0,0),
  (0,0,0,0,0,1,0,0,0,0,0,0,0,0,0,0),
  (0,0,0,0,0,0,1,0,0,0,0,0,0,0,0,0),
  (0,0,0,0,0,0,0,1,0,0,0,0,0,0,0,0),
  (0,0,0,0,0,0,0,0,1,0,0,0,0,0,0,0),
  (0,0,0,0,0,0,0,0,0,1,0,0,0,0,0,0),
  (0,0,0,0,0,0,0,0,0,0,1,0,0,0,0,0),
  (0,0,0,0,0,0,0,0,0,0,0,1,0,0,0,0),
  (0,0,0,0,0,0,0,0,0,0,0,0,1,0,0,0),
  (0,0,0,0,0,0,0,0,0,0,0,0,0,1,0,0),
  (0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,0),
  (0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1)]"
  by (auto simp: Basis_list_prod_def zero_prod_def)

interpretation quadrot: ode_interpretation "Conj (Less (- Half Pi) (Var 8))
  (Conj (Less (Var 8) (Half Pi)) ((Less (Var 3)
  ((Num (Float 89 (- 6)))))))"
  "{(t, x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, u1, u2, u3).
    x3 < 89/64 \<and> x8 \<in> {-pi/2<..<pi/2}}"
  quadrot_fas
  "\<lambda>(t::real, x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, u1, u2, u3). (1,
    \<comment> \<open>\<open>x\<^sub>1\<close>:\<close> cos (x8) * cos (x9)* x4 + (sin(x7) * sin(x8) * cos (x9) - cos(x7) * sin(x9))*x5
              + (cos(x7) * sin(x8) * cos(x9) + sin(x7) * sin(x9)) * x6,
    \<comment> \<open>\<open>x\<^sub>2\<close>:\<close> cos(x8) * sin (x9) * x4 + (sin(x7) * sin (x8) * sin(x9) + cos(x7) * cos (x9))*x5
              + (cos(x7) * sin(x8) * sin(x9) - sin ( x7) * cos (x9)) * x6,
    \<comment> \<open>\<open>x\<^sub>3\<close>:\<close> sin(x8) * x4 - sin(x7) * cos (x8) * x5 - cos(x7) *cos(x8)*x6,
    \<comment> \<open>\<open>x\<^sub>4\<close>:\<close> x12 * x5- x11*x6 - g * sin(x8),
    \<comment> \<open>\<open>x\<^sub>5\<close>:\<close> x10 * x6 - x12*x4 + g * cos(x8 * sin(x7)),
    \<comment> \<open>\<open>x\<^sub>6\<close>:\<close> x11 * x4 - x10*x5 + g * cos(x8 * cos(x7)) - Fr x3 x6 u1 / m,
    \<comment> \<open>\<open>x\<^sub>7\<close>:\<close> x10 + (sin(x7)*tan(x8))*x11 + (cos(x7)*tan(x8))*x12,
    \<comment> \<open>\<open>x\<^sub>8\<close>:\<close> cos(x7) * x11 - sin(x7)*x12,
    \<comment> \<open>\<open>x\<^sub>9\<close>:\<close> sin(x7) / cos(x8) * x11 + cos(x7)/cos(x8)*x12,
    \<comment> \<open>\<open>x\<^sub>1\<^sub>0\<close>:\<close> (J\<^sub>y - J\<^sub>z)/J\<^sub>x*x11*x12 + (- (x7 - u2) - x10) / J\<^sub>x,
    \<comment> \<open>\<open>x\<^sub>1\<^sub>1\<close>:\<close> (J\<^sub>z - J\<^sub>x)/J\<^sub>y*x10*x12 + (- (x8 - u3) - x11) / J\<^sub>y,
    \<comment> \<open>\<open>x\<^sub>1\<^sub>2\<close>:\<close> (J\<^sub>x - J\<^sub>y)/J\<^sub>z*x10*x11 + 0 / J\<^sub>z,
    \<comment> \<open>\<open>u\<^sub>1\<close>:\<close> 0::real,
    \<comment> \<open>\<open>u\<^sub>2\<close>:\<close> 0::real,
    \<comment> \<open>\<open>u\<^sub>3\<close>:\<close> 0::real)" "sixteen::16"
  apply standard
  subgoal by simp
  subgoal by (simp add: quadrot_fas_def)
  subgoal by (auto simp: Basis_list_16)
  subgoal
    using cos_gt_zero_pi
    apply (simp add: quadrot_fas_def Basis_list_16)
    apply (auto simp: eucl_of_list_prod split: prod.splits)
    apply (auto simp: power2_eq_square quadrot_fas_def)
    by (auto simp: approximation_preproc_floatarith[symmetric])
  subgoal by (auto simp: mk_ode_ops_def quadrot_fas_def Half_def)
  subgoal
    using cos_gt_zero_pi
    by (fastforce simp: quadrot_fas_def less_Suc_eq_0_disj nth_Basis_list_prod isFDERIV_product
      mk_ode_ops_def eucl_of_list_prod power2_eq_square inverse_eq_divide intro!: isFDERIV_I)
  done

lemma quadrot: "t \<in> {5 .. 5} \<longrightarrow>
    (s,   x1,   x2,   x3,   x4,   x5,   x6, x7, x8, x9, x10, x11, x12, u1, u2, u3) \<in>
   {(0, -0.4, -0.4, -0.4, -0.4, -0.4, -0.4,  0,  0,  0,   0,   0,   0,  1,  0,  0) ..
    (0,  0.4,  0.4,  0.4,  0.4,  0.4,  0.4,  0,  0,  0,   0,   0,   0,  1,  0,  0)} \<longrightarrow>
   t \<in> quadrot.existence_ivl0 (s, x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, u1, u2, u3) \<and>
    quadrot.flow0 (s, x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, u1, u2, u3) t \<in>
      {(4.99, -2.5, 120, 0.98, -0.5, 48, -0.05, 0, 0, 0, 0, 0, 0, 1, 0, 0) ..
       (5.01,  2.5, 126, 1.02,  0.5, 50,  0.05, 0, 0, 0, 0, 0, 0, 1, 0, 0)}
      \<^cancel>\<open>{(4.9, -2.5, 120, 0.99, -0.5, 48, -0.02, 0, 0, 0, 0, 0, 0, 1, 0, 0) ..
       (5.0,  2.5, 126, 1.00,  0.5, 50,  0.02, 0, 0, 0, 0, 0, 0, 1, 0, 0)}\<close>"
  by (tactic \<open>ode_bnds_tac @{thms quadrot_fas_def} 16 25 20 10 [(0, 3, "0x000000")]
    (* "out_quadrot.out" *) ""  @{context} 1\<close>)

end

subsection \<open>Laub Loomis\<close>
experiment begin

unbundle floatarith_notation

schematic_goal laub_fas:
  "[1,
    1.4 * X ! 3 - 0.9 * X ! 1,
    2.5 * X ! 5 - 1.5 * X ! 2,
    0.6 * X ! 7 - 0.8 * X ! 2 * X ! 3,
    2           - 1.3 * X ! 3 * X ! 4,
    0.7 * X ! 1 -       X ! 4 * X ! 5,
    0.3 * X ! 1 - 3.1 * X ! 6,
    1.8 * X ! 6 - 1.5 * X ! 2 * X ! 7]
  = interpret_floatariths ?fas X"
  by (reify_floatariths)

concrete_definition laub_fas uses laub_fas

interpretation ll: ode_interpretation "Less (Var 4) (Num 50)"
  "{(t, x1, x2, x3, x4, x5, x6, x7).
      x4 < 50 \<comment> \<open>modify for safety requirements of ARCH-competition\<close>}"
  laub_fas
  "\<lambda>(t, x1, x2, x3, x4, x5, x6, x7).
    (1,
     1.4 * x3 - 0.9 * x1,
     2.5 * x5 - 1.5 * x2,
     0.6 * x7 - 0.8 * x2 * x3,
     2 - 1.3 * x3 * x4,
     0.7 * x1 - x4 * x5,
     0.3 * x1 - 3.1 * x6,
     1.8 * x6 - 1.5 * x2 * x7)::real*real*real*real*real*real*real*real" "eight::8"
  by standard
    (auto simp: laub_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 inverse_eq_divide intro!: isFDERIV_I)

theorem ll_001:
  "t \<in> {20 .. 20} \<longrightarrow>
  (s, x1, x2, x3, x4, x5, x6, x7) \<in>
      {(0, 1.19, 1.04, 1.49, 2.39, 0.99, 0.09, 0.44) ..
       (0, 1.21, 1.06, 1.51, 2.41, 1.01, 0.11, 0.46)} \<longrightarrow>
  t \<in> ll.existence_ivl0 (s, x1, x2, x3, x4, x5, x6, x7) \<and>
  ll.flow0 (s, x1, x2, x3, x4, x5, x6, x7) t \<in>
    {(19.99, 0.8, 0.3, 0.5, 2.5, 0.1, 0.0, 0.25) ..
     (20, 1.0, 0.5, 0.7, 3.0, 0.3, 0.1, 0.35)}"
  by (tactic \<open>ode_bnds_tac @{thms laub_fas_def} 30 60 30 13 [(0, 4, "0x7f7f7f")] (* "out_ll_001.out" *) ""  @{context} 1\<close>)

theorem ll_005:
  "t \<in> {20 .. 20} \<longrightarrow>
  (s, x1, x2, x3, x4, x5, x6, x7) \<in>
      {(0, 1.15, 1.00, 1.45, 2.35, 0.95, 0.05, 0.40) ..
       (0, 1.25, 1.10, 1.55, 2.45, 1.05, 0.15, 0.50)} \<longrightarrow>
  t \<in> ll.existence_ivl0 (s, x1, x2, x3, x4, x5, x6, x7) \<and>
  ll.flow0 (s, x1, x2, x3, x4, x5, x6, x7) t \<in>
    {(19.99, 0.8, 0.3, 0.5, 2.4, 0.1, 0.0, 0.25) ..
     (20, 1.0, 0.5, 0.7, 3.0, 0.3, 0.1, 0.35)}"
  by (tactic \<open>ode_bnds_tac  @{thms laub_fas_def} 30 60 30 13 [(0, 4, "0x000000")] (* "out_ll_005.out" *) "" @{context} 1\<close>)

theorem ll_010:
  "t \<in> {10 .. 10} \<longrightarrow>
  (s, x1, x2, x3, x4, x5, x6, x7) \<in>
      {(0, 1.10, 0.95, 1.40, 2.30, 0.90, 0.00, 0.35) ..
       (0, 1.30, 1.15, 1.60, 2.50, 1.10, 0.20, 0.55)} \<longrightarrow>
  t \<in> ll.existence_ivl0 (s, x1, x2, x3, x4, x5, x6, x7) \<and>
  ll.flow0 (s, x1, x2, x3, x4, x5, x6, x7) t \<in>
    {(9.99, 0.2, -0.8, -0.4, -1.3, -1.2, 0.0, -0.5) ..
     (10,   1.8, 1.6, 1.8, 6.2, 1.7, 0.2, 1.2)}"
  by (tactic \<open>ode_bnds_tac  @{thms laub_fas_def} 30 60 30 13 [(0, 4, "0x0000ff")] (* "out_ll_010.out" *) ""  @{context} 1\<close>)

end

subsection \<open>Van der Pol oscillator (with time and ``pseudo-invariant''\<close>
experiment begin

schematic_goal vdp_fas:
  "[1, X!2, X!3 * X!2 * (1 - (X!1)\<^sup>2) - X!1, 0 \<comment> \<open>\<mu>'\<close> ] = interpret_floatariths ?fas X"
  by (reify_floatariths)

concrete_definition vdp_fas uses vdp_fas

interpretation vdp: ode_interpretation true_form UNIV vdp_fas "\<lambda>(t, x, y, \<mu>). (1, y, \<mu> * y * (1 - x\<^sup>2) - x, 0)::real*real*real*real"
  "n::4" 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 inverse_eq_divide intro!: isFDERIV_I)

abbreviation "vdp_ro \<equiv> ro 2 10 7 2 2 2"

lemma vdp_ro: "TAG_reach_optns vdp_ro" by simp

lemma vdp_start: "TAG_sctn False" by simp

lemma poincare_section_rep1:
  "{(7::real, -3::real, -3::real, -10::real)..(7, 3, 3, 10)} = {eucl_of_list [7, -3, -3, -10]..eucl_of_list [7, 3, 3, 10]}"
  by (auto simp: eucl_of_list_prod)

lemma vdp_pi_1: "vdp.guards_invar DIM(real \<times> real \<times> real \<times> real) [([ysec4' (1,7) (3/2) (-2, 0) (-10, 10)], vdp_ro)]"
  by (auto simp: vdp.guards_invar_def)

lemma
  notes [poincare_tac_theorems] = vdp_ro vdp_start vdp_pi_1 poincare_section_rep1
  shows "\<forall>x\<in>{(0, 1.25, 2.35, 1) .. (0, 1.55, 2.45, 1)}.
  vdp.returns_to   {(7, -3, -3, -10) .. (7, 3, 3, 10)} x \<and>
  vdp.poincare_map_from_outside {(7, -3, -3, -10) .. (7, 3, 3, 10)} x \<in> {(7, 0, 0, -10) .. (7, 3, 3, 10)}"
  by (tactic \<open>poincare_bnds_tac @{thms vdp_fas_def} 30 20 10 14 [(1, 2, "0x007f00")] (* "out_p1_vdp_mu1_0.out" *) ""  @{context} 1\<close>)

abbreviation "t2 \<equiv> 15/2"
lemma vdp_pi_2: "vdp.guards_invar DIM(real \<times> real \<times> real \<times> real) [([ysec4' (1,t2) (7/2/2) (-2, 0) (-10, 10)], vdp_ro),
  ([ysec4 (1,t2) (-3/2) (-1, 1) (-10, 10)], vdp_ro)]"
  by (auto simp: vdp.guards_invar_def)

lemma poincare_section_rep2:
  "{(t2::real, -30::real, -30::real, -10::real)..(t2, 30, 30, 10)} = {eucl_of_list [t2, -30, -30, -10]..eucl_of_list [t2, 30, 30, 10]}"
  by (auto simp: eucl_of_list_prod)

lemma
  notes [poincare_tac_theorems] = vdp_ro vdp_start vdp_pi_2 poincare_section_rep2
  shows "\<forall>x\<in>{(0, 1.55, 2.35, 2) .. (0, 1.85, 2.45, 2)}.
  vdp.returns_to   {(t2, -30, -30, -10) .. (t2, 30, 30, 10)} x \<and>
  vdp.poincare_map_from_outside {(t2, -30, -30, -10) .. (t2, 30, 30, 10)} x \<in> {(t2, -30, -30, -10) .. (t2, 30, 30, 10)}"
  by (tactic \<open>poincare_bnds_tac @{thms vdp_fas_def} 30 20 10 14 [(1, 2, "0x00007f")] (* "out_p1_vdp_mu2_0.out" *) "" @{context} 1\<close>)

end

end


theory Experiment
  imports Main "HOL-Library.Mapping" "HOL-Library.RBT_Mapping" "HOL-Library.RBT_Set" "HOL-Library.Quotient_Product"
    (* TODO: import RBT_Set later to get better output? *)
begin

record ('state, 'input, 'output) fsm_impl =
  initial_impl :: 'state
  nodes_impl :: "'state set"
  inputs_impl  :: "'input set"
  outputs_impl  :: "'output set"
  transitions_impl :: "('state \<times> 'input \<times> 'output \<times> 'state) set"

(* TODO: add common subexpression elimination to avoid nested recalculation? *)
definition set_as_map :: "('a \<times> 'b \<times> 'c) set \<Rightarrow> ('a \<times> 'b \<Rightarrow> 'c set option)" where
  "set_as_map s = (\<lambda> (x,y) . if (\<exists> z . (x,y,z) \<in> s) then Some {z . (x,y,z) \<in> s} else None)"

(* TODO: prove equivalent result for normal Map type to allow for a later import of Maping ? *)
lemma set_as_map_code[code] : "set_as_map (RBT_Set.Set t) = Mapping.lookup (foldl (\<lambda> m ((x,y,z),()) . case Mapping.lookup m (x,y) of
None \<Rightarrow> Mapping.update (x,y) {z} m |
Some zs \<Rightarrow> Mapping.update (x,y) (insert z zs) m)
Mapping.empty
(RBT.entries t))"
proof -
  let ?f = "\<lambda> xs . (foldl (\<lambda> m ((x,y,z),()) . case Mapping.lookup m (x,y) of
None \<Rightarrow> Mapping.update (x,y) {z} m |
Some zs \<Rightarrow> Mapping.update (x,y) (insert z zs) m)
Mapping.empty
                                                       xs)"

  have *:"\<And> xs :: (('a \<times> 'b \<times> 'c) \<times> unit) list. Mapping.lookup (?f xs) = (\<lambda> (x,y) . if (\<exists> z . ((x,y,z),()) \<in> set xs) then Some {z . ((x,y,z),()) \<in> set xs} else None)"
  proof -
    fix xs :: "(('a \<times> 'b \<times> 'c) \<times> unit) list"
    show "Mapping.lookup (?f xs) = (\<lambda> (x,y) . if (\<exists> z . ((x,y,z),()) \<in> set xs) then Some {z . ((x,y,z),()) \<in> set xs} else None)"
    proof (induction xs rule: rev_induct)
      case Nil
      have "(?f []) = Mapping.empty"  by auto
      then have "Mapping.lookup (?f []) = (\<lambda> (x,y) . None)"
        using Mapping.lookup_empty by fastforce
      moreover have "(\<lambda> (x,y) . if (\<exists> z . ((x,y,z),()) \<in> set []) then Some {z . ((x,y,z),()) \<in> set []} else None) = (\<lambda> (x,y) . None)" by auto
      ultimately show ?case
        by (simp add: cond_case_prod_eta)
    next
      case (snoc xyz xs)
      then obtain x y z where "xyz = ((x,y,z),())"
        by (metis (mono_tags, hide_lams) old.unit.exhaust surj_pair)

      have scheme: "\<And> x xs f y . foldl f y (xs@[x]) = f (foldl f y xs) x"
        by simp
      have *: "(?f (xs@[((x,y,z),())])) = (case Mapping.lookup (?f xs) (x,y) of
                                  None \<Rightarrow> Mapping.update (x,y) {z} (?f xs) |
                                  Some zs \<Rightarrow> Mapping.update (x,y) (insert z zs) (?f xs))"
        unfolding scheme by auto

      then show ?case proof (cases "Mapping.lookup (?f xs) (x,y)")
        case None
        then have **: "(?f (xs@[((x,y,z),())])) = Mapping.update (x,y) {z} (?f xs)" using * by auto

        have scheme: "\<And> m k v . Mapping.lookup (Mapping.update k v m) = (\<lambda>k' . if k' = k then Some v else Mapping.lookup m k')"
          using lookup_update lookup_update_neq by metis

        have m1: "Mapping.lookup (?f (xs@[((x,y,z),())])) = (\<lambda> (x',y') . if (x',y') = (x,y) then Some {z} else Mapping.lookup (?f xs) (x',y'))"
          unfolding ** scheme by force

        have "(\<lambda> (x,y) . if (\<exists> z . ((x,y,z),()) \<in> set xs) then Some {z . ((x,y,z),()) \<in> set xs} else None) (x,y) = None"
          using None snoc by auto
        then have "\<not>(\<exists> z . ((x,y,z),()) \<in> set xs)"
          by (metis (mono_tags, lifting) case_prod_conv option.distinct(1))
        then have "(\<exists> z . ((x,y,z),()) \<in> set (xs@[((x,y,z),())]))" and "{z' . ((x,y,z'),()) \<in> set (xs@[((x,y,z),())])} = {z}"
          by auto
        then have m2: "(\<lambda> (x',y') . if (\<exists> z' . ((x',y',z'),()) \<in> set (xs@[((x,y,z),())])) then Some {z' . ((x',y',z'),()) \<in> set (xs@[((x,y,z),())])} else None)
                     = (\<lambda> (x',y') . if (x',y') = (x,y) then Some {z} else (\<lambda> (x,y) . if (\<exists> z . ((x,y,z),()) \<in> set xs) then Some {z . ((x,y,z),()) \<in> set xs} else None) (x',y'))"
          by auto

        show ?thesis using m1 m2 snoc
          using \<open>xyz = ((x, y, z), ())\<close> by presburger

      next
        case (Some zs)
        then have **: "(?f (xs@[((x,y,z),())])) = Mapping.update (x,y) (insert z zs) (?f xs)" using * by auto
        have scheme: "\<And> m k v . Mapping.lookup (Mapping.update k v m) = (\<lambda>k' . if k' = k then Some v else Mapping.lookup m k')"
          using lookup_update lookup_update_neq by metis

        have m1: "Mapping.lookup (?f (xs@[((x,y,z),())])) = (\<lambda> (x',y') . if (x',y') = (x,y) then Some (insert z zs) else Mapping.lookup (?f xs) (x',y'))"
          unfolding ** scheme by force

        have "(\<lambda> (x,y) . if (\<exists> z . ((x,y,z),()) \<in> set xs) then Some {z . ((x,y,z),()) \<in> set xs} else None) (x,y) = Some zs"
          using Some snoc by auto
        then have "(\<exists> z . ((x,y,z),()) \<in> set xs)"
          unfolding case_prod_conv using  option.distinct(2) by metis
        then have "(\<exists> z . ((x,y,z),()) \<in> set (xs@[((x,y,z),())]))" by simp

        have "{z' . ((x,y,z'),()) \<in> set (xs@[((x,y,z),())])} = insert z zs"
        proof -
          have "Some {z . ((x,y,z),()) \<in> set xs} = Some zs"
            using \<open>(\<lambda> (x,y) . if (\<exists> z . ((x,y,z),()) \<in> set xs) then Some {z . ((x,y,z),()) \<in> set xs} else None) (x,y) = Some zs\<close>
            unfolding case_prod_conv using  option.distinct(2) by metis
          then have "{z . ((x,y,z),()) \<in> set xs} = zs" by auto
          then show ?thesis by auto
        qed

        have "\<And> a b . (\<lambda> (x',y') . if (\<exists> z' . ((x',y',z'),()) \<in> set (xs@[((x,y,z),())])) then Some {z' . ((x',y',z'),()) \<in> set (xs@[((x,y,z),())])} else None) (a,b)
                     = (\<lambda> (x',y') . if (x',y') = (x,y) then Some (insert z zs) else (\<lambda> (x,y) . if (\<exists> z . ((x,y,z),()) \<in> set xs) then Some {z . ((x,y,z),()) \<in> set xs} else None) (x',y')) (a,b)"
        proof -
          fix a b show "(\<lambda> (x',y') . if (\<exists> z' . ((x',y',z'),()) \<in> set (xs@[((x,y,z),())])) then Some {z' . ((x',y',z'),()) \<in> set (xs@[((x,y,z),())])} else None) (a,b)
                     = (\<lambda> (x',y') . if (x',y') = (x,y) then Some (insert z zs) else (\<lambda> (x,y) . if (\<exists> z . ((x,y,z),()) \<in> set xs) then Some {z . ((x,y,z),()) \<in> set xs} else None) (x',y')) (a,b)"
          using \<open>{z' . ((x,y,z'),()) \<in> set (xs@[((x,y,z),())])} = insert z zs\<close> \<open>(\<exists> z . ((x,y,z),()) \<in> set (xs@[((x,y,z),())]))\<close>
          by (cases "(a,b) = (x,y)"; auto)
        qed

        then have m2: "(\<lambda> (x',y') . if (\<exists> z' . ((x',y',z'),()) \<in> set (xs@[((x,y,z),())])) then Some {z' . ((x',y',z'),()) \<in> set (xs@[((x,y,z),())])} else None)
                     = (\<lambda> (x',y') . if (x',y') = (x,y) then Some (insert z zs) else (\<lambda> (x,y) . if (\<exists> z . ((x,y,z),()) \<in> set xs) then Some {z . ((x,y,z),()) \<in> set xs} else None) (x',y'))"
          by auto

        show ?thesis using m1 m2 snoc
          using \<open>xyz = ((x, y, z), ())\<close> by presburger
      qed
    qed
  qed

  show ?thesis
    using *[of "RBT.entries t"]
    unfolding set_as_map_def
    unfolding member_code(1)[of _ t] unfolding lookup_in_tree[of t _ "()"] by auto
qed

value "set_as_map {(1::nat,1::nat,1::nat),(1,1,2),(1,2,1),(2,4,1),(1,2,2)} (1,1)"

lift_definition set_as_mapping :: "('a \<times> 'b \<times> 'c) set \<Rightarrow> ('a \<times> 'b, 'c set) mapping" is set_as_map done
lemma[code] : "set_as_mapping (RBT_Set.Set t) = (foldl (\<lambda> m ((x,y,z),()) . case Mapping.lookup m (x,y) of
None \<Rightarrow> Mapping.update (x,y) {z} m |
Some zs \<Rightarrow> Mapping.update (x,y) (insert z zs) m)
Mapping.empty
(RBT.entries t))"
  using set_as_map_code[of t]
  unfolding set_as_map_def set_as_mapping.abs_eq
  using Mapping.lookup.abs_eq
  by (simp add: Mapping.lookup.abs_eq mapping_eqI)

value "set_as_mapping {(1::nat,1::nat,1::nat),(1,1,2),(1,2,1),(2,4,1),(1,2,2)}"

definition h :: "('state, 'input, 'output) fsm_impl \<Rightarrow> ('state \<times> 'input) \<Rightarrow> ('output \<times> 'state) set" where
  "h M = (\<lambda> (q,x) . {(y,q') . (q,x,y,q') \<in> transitions_impl M})"

lemma[code] : "h M = (let m = set_as_map (transitions_impl M) in (\<lambda> (q,x) . case m (q,x) of Some ts \<Rightarrow> ts | None \<Rightarrow> {}))"
proof
  fix qx
  let ?f = "(let m = set_as_map (transitions_impl M) in (\<lambda> (q,x) . case m (q,x) of Some ts \<Rightarrow> ts | None \<Rightarrow> {}))"

  have "\<And> yq . yq \<in> h M qx \<Longrightarrow> yq \<in> ?f qx"
    unfolding set_as_map_def h_def
    by force
  moreover have "\<And> yq . yq \<in> ?f qx \<Longrightarrow> yq \<in> h M qx"
  proof -
    fix yq assume "yq \<in> ?f qx"
    then obtain zs where "(set_as_map (transitions_impl M)) qx = Some zs" and "yq \<in> zs"
      unfolding Let_def
      by (metis (no_types, lifting) equals0D mem_case_prodE option.case_eq_if option.collapse)
    then have "yq \<in> {z. (fst qx, snd qx, z) \<in> transitions_impl M}"
      unfolding set_as_map_def
    proof -
      assume "(case qx of (x, y) \<Rightarrow> if \<exists>z. (x, y, z) \<in> transitions_impl M then Some {z. (x, y, z) \<in> transitions_impl M} else None) = Some zs"
      then have "(if \<exists>p. (fst qx, snd qx, p) \<in> transitions_impl M then Some {p. (fst qx, snd qx, p) \<in> transitions_impl M} else None) = Some zs"
        by (simp add: case_prod_beta')
      then show ?thesis
        by (metis \<open>yq \<in> zs\<close> option.discI option.inject)
    qed
    then show "yq \<in> h M qx"
      unfolding h_def by auto
  qed
  ultimately show "h M qx = ?f qx" by blast
qed

end (*

fun h_impl :: "('state, 'input, 'output) fsm_impl \<Rightarrow> ('state \<times> 'input) \<Rightarrow> ('output \<times> 'state) set" where
  "h_impl M qx = (case h'_impl M qx of None \<Rightarrow> {} | Some yqs \<Rightarrow> yqs)"

definition fsm_impl_empty :: "'a \<Rightarrow> ('a,'b,'c) fsm_impl" where
  "fsm_impl_empty q = \<lparr> initial_impl = q, nodes_impl = {q}, inputs_impl = {}, outputs_impl = {}, h'_impl = Map.empty \<rparr>"

definition update_h'_impl :: "('a \<rightharpoonup> ('b set)) \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> ('a \<rightharpoonup> ('b set))" where
  "update_h'_impl hM qx yq' = (case (hM qx) of None \<Rightarrow> hM (qx \<mapsto> {yq'}) | Some yqs \<Rightarrow> hM (qx \<mapsto> insert yq' yqs))"

lift_definition update_h'_impl' :: "('a, 'b set) mapping \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> ('a, 'b set) mapping"
  is update_h'_impl done

lemma[code] : "update_h'_impl' hM qx yq' = (case (Mapping.lookup hM qx) of None \<Rightarrow> Mapping.update qx {yq'} hM | Some yqs \<Rightarrow> Mapping.update qx (insert yq' yqs) hM)"
  by transfer (fact update_h'_impl_def)

value "update_h'_impl' Mapping.empty (1::nat) (2::nat)"
value "update_h'_impl Map.empty (1::nat) (2::nat)"

export_code update_h'_impl update_h'_impl' in Haskell

(*
record ('state, 'input, 'output) fsm_impl_m =
  initial_impl :: 'state
  nodes_impl :: "'state set"
  inputs_impl  :: "'input set"
  outputs_impl  :: "'output set"
  h'_impl :: "(('state \<times> 'input), (('output \<times> 'state) set)) mapping"

lift_definition h_impl_m :: "('state, 'input, 'output) fsm_impl_m \<Rightarrow> ('state \<times> 'input) \<Rightarrow> ('output \<times> 'state) set" is h_impl done
lemma[code] : "h_impl_m M = (case (Mapping.lookup (h'_impl M) qx) of None \<Rightarrow> {} | Some yqs \<Rightarrow> yqs)"
*)

fun fsm_impl_from_list :: "'a \<Rightarrow> ('a \<times> 'x \<times> 'y \<times> 'a) list \<Rightarrow> ('a,'x,'y) fsm_impl" where
  "fsm_impl_from_list q [] = fsm_impl_empty q" |
  "fsm_impl_from_list q ((q1,x,y,q2)#ts) = (let M = fsm_impl_from_list q ts
                                             in \<lparr> initial_impl = initial_impl M,
                                                  nodes_impl = nodes_impl M \<union> {q1,q2},
                                                  inputs_impl = insert x (inputs_impl M),
                                                  outputs_impl = insert y (outputs_impl M),
                                                  h'_impl = update_h'_impl (h'_impl M) (q1,x) (y,q2) \<rparr>)"

value "fsm_impl_from_list 0 ([] :: (nat \<times> nat \<times> nat \<times> nat) list)"

(*
lemma[code] : "fsm_impl_empty q = \<lparr> initial_impl = q, nodes_impl = {q}, inputs_impl = {}, outputs_impl = {}, h'_impl = Mapping.empty \<rparr>"
*)

typedef ('state, 'input, 'output) fsm = "{ M :: ('state, 'input, 'output) fsm_impl . initial_impl M \<in> nodes_impl M
\<and> finite (nodes_impl M)
\<and> finite (inputs_impl M)
\<and> finite (outputs_impl M)
\<and> (\<forall> q x y q' . (y,q') \<in> h_impl M (q,x) \<longrightarrow> (q \<in> nodes_impl M \<and> x \<in> inputs_impl M \<and> q' \<in> nodes_impl M \<and> y \<in> outputs_impl M))}"
  morphisms fsm_impl Fsm
proof -
  obtain q :: 'state where "True" by blast
  define M :: "('state, 'input, 'output) fsm_impl" where "M = \<lparr> initial_impl = q, nodes_impl = {q}, inputs_impl = {}, outputs_impl = {}, h'_impl = Map.empty \<rparr>"
  then have "initial_impl M \<in> nodes_impl M
              \<and> finite (nodes_impl M)
              \<and> finite (inputs_impl M)
              \<and> finite (outputs_impl M)
              \<and> (\<forall> q x y q' . (y,q') \<in> h_impl M (q,x) \<longrightarrow> (q \<in> nodes_impl M \<and> x \<in> inputs_impl M \<and> q' \<in> nodes_impl M \<and> y \<in> outputs_impl M))"
    by auto
  then show ?thesis by blast
qed

definition set_mapping_rel :: "('a \<rightharpoonup> 'b set) \<Rightarrow> ('a, 'b set) mapping \<Rightarrow> bool" where
 "set_mapping_rel m1 m2 = (\<forall> a . m1 a = Mapping.lookup m2 a)"

definition rel_mm :: "('a \<Rightarrow> 'c \<Rightarrow> bool) \<Rightarrow> ('b \<Rightarrow> 'd \<Rightarrow> bool) \<Rightarrow> ('a \<rightharpoonup> 'b) \<Rightarrow> ('c, 'd) mapping \<Rightarrow> bool" where
 "rel_mm A B m1 m2 = (\<forall> a c . A a c \<longrightarrow>  rel_option B (m1 a) (Mapping.lookup m2 c))"

definition rel_mm' :: "('a \<Rightarrow> 'c \<Rightarrow> bool) \<Rightarrow> ('b \<Rightarrow> 'd \<Rightarrow> bool) \<Rightarrow> ('a \<rightharpoonup> 'b) \<Rightarrow> ('c, 'd) mapping \<Rightarrow> bool" where
 "rel_mm' A B m1 m2 = (\<forall> a c . A a c \<longrightarrow>  ((m1 a = None \<and> Mapping.lookup m2 c = None) \<or> (\<exists> b d . m1 a = Some b \<and> Mapping.lookup m2 c = Some d \<and> B b d)))"

thm rel_funD
thm rel_optionI

(* TODO: fix warning *)
setup_lifting type_definition_fsm

lift_definition initial :: "('state, 'input, 'output) fsm \<Rightarrow> 'state" is initial_impl done
lift_definition nodes :: "('state, 'input, 'output) fsm \<Rightarrow> 'state set" is nodes_impl done
lift_definition inputs :: "('state, 'input, 'output) fsm \<Rightarrow> 'input set" is inputs_impl done
lift_definition outputs :: "('state, 'input, 'output) fsm \<Rightarrow> 'output set" is outputs_impl done
lift_definition h :: "('state, 'input, 'output) fsm \<Rightarrow> ('state \<times> 'input) \<Rightarrow> (('output \<times> 'state) set)" is h_impl done

lift_definition fsm_empty :: "'a \<Rightarrow> ('a,'b,'c) fsm" is fsm_impl_empty
  unfolding fsm_impl_empty_def by auto

value "(nodes ((fsm_empty 0) :: (nat,nat,nat) fsm))"
value "initial ((fsm_empty 15) :: (nat,nat,nat) fsm)"

lemma "initial M \<in> nodes M" using fsm_impl unfolding initial.rep_eq nodes.rep_eq by blast
lemma "finite (nodes M)" using fsm_impl unfolding nodes.rep_eq by blast
lemma "finite (inputs M)" using fsm_impl unfolding inputs.rep_eq by blast
lemma "finite (outputs M)" using fsm_impl unfolding outputs.rep_eq by blast
lemma "\<And> q x y q' . (y,q') \<in> h M (q,x) \<Longrightarrow> (q \<in> nodes M \<and> x \<in> inputs M \<and> q' \<in> nodes M \<and> y \<in> outputs M)"
  using fsm_impl[of M]
  unfolding nodes.rep_eq inputs.rep_eq outputs.rep_eq h.rep_eq by blast

definition fsm_empty :: "'a \<Rightarrow> ('a,'b,'c) fsm" where
  "fsm_empty q = Fsm \<lparr> initial_impl = q, nodes_impl = {q}, inputs_impl = {}, outputs_impl = {}, h'_impl = Map.empty \<rparr>"

lemma fsm_empty_code[code abstract]:
  "fsm_impl (fsm_empty q :: ('a,'b,'c) fsm) = \<lparr> initial_impl = q, nodes_impl = {q}, inputs_impl = {}, outputs_impl = {}, h'_impl = Map.empty \<rparr>"
  unfolding fsm_empty_def
  using Fsm_inverse[of "\<lparr> initial_impl = q, nodes_impl = {q}, inputs_impl = {}, outputs_impl = {}, h'_impl = Map.empty \<rparr>"] by auto

value "card (nodes ((fsm_empty 0) :: (nat,nat,nat) fsm))"

definition add_transition :: "('a \<times> 'x \<times> 'y \<times> 'a) \<Rightarrow> ('a,'x,'y) fsm \<Rightarrow> ('a,'x,'y) fsm" where
  "add_transition (q,x,y,q') M = (* TODO: define on fsm_impl and then lift? *)

fun fsm_from_list :: "'a \<Rightarrow> ('a \<times> 'x \<times> 'y \<times> 'a) list \<Rightarrow> ('a,'x,'y) fsm" where
  "fsm_from_list q [] = fsm_empty q" |
  "fsm_from_list q (t#ts) =

end (*

(* IDEA: use ('state \<times> 'input) \<Rightarrow> (('output \<times> 'state) set) as h instead of ('state \<times> 'input) \<rightharpoonup> (('output \<times> 'state) set) to avoid always checking whether h M (q,x) is defined *)

record ('state, 'input, 'output) fsm_impl =
  initial_impl :: 'state
  nodes_impl :: "'state set"
  inputs_impl  :: "'input set"
  outputs_impl  :: "'output set"
  h_impl :: "('state \<times> 'input) \<Rightarrow> (('output \<times> 'state) set)"

typedef ('state, 'input, 'output) fsm = "{ M :: ('state, 'input, 'output) fsm_impl . initial_impl M \<in> nodes_impl M
\<and> finite (nodes_impl M)
\<and> finite (inputs_impl M)
\<and> finite (outputs_impl M)
\<and> (\<forall> q x y q' . (y,q') \<in> h_impl M (q,x) \<longrightarrow> (q \<in> nodes_impl M \<and> x \<in> inputs_impl M \<and> q' \<in> nodes_impl M \<and> y \<in> outputs_impl M))}"
  morphisms fsm_impl Fsm
proof -
  obtain q :: 'state where "True" by blast
  define M :: "('state, 'input, 'output) fsm_impl" where "M = \<lparr> initial_impl = q, nodes_impl = {q}, inputs_impl = {}, outputs_impl = {}, h_impl = (\<lambda> (q,x) . {}) \<rparr>"
  then have "initial_impl M \<in> nodes_impl M
              \<and> finite (nodes_impl M)
              \<and> finite (inputs_impl M)
              \<and> finite (outputs_impl M)
              \<and> (\<forall> q x y q' . (y,q') \<in> h_impl M (q,x) \<longrightarrow> (q \<in> nodes_impl M \<and> x \<in> inputs_impl M \<and> q' \<in> nodes_impl M \<and> y \<in> outputs_impl M))"
    by auto
  then show ?thesis by blast
qed

typedef ('a,'b) set_fun = "UNIV :: ('a \<Rightarrow> ('b set)) set" ..
setup_lifting type_definition_set_fun

definition set_fun_default :: "('a,'b) set_fun \<Rightarrow> 'b set" where
  "set_fun_default f = {}"

definition set_fun_empty :: "('a,'b) set_fun" where
  "set_fun_empty = Abs_set_fun (\<lambda> x . {})"

definition set_fun_update :: "('a, 'b) set_fun \<Rightarrow> 'a \<Rightarrow> 'b set \<Rightarrow> ('a, 'b) set_fun" where
  "set_fun_update f x y = Abs_set_fun ((Rep_set_fun f)(x := y))"

(*
lift_definition fun_update ::  "('a, 'b) set_fun \<Rightarrow> 'a \<Rightarrow> 'b set \<Rightarrow> ('a, 'b) set_fun" is fun_upd .

lemma "set_fun_update = fun_update"
  unfolding set_fun_update_def fun_update_def sledgehammer *)

definition h_empty :: "('state \<times> 'input) \<Rightarrow> (('output \<times> 'state) set)" where
  "h_empty = (\<lambda> (q,x) . {})"

lift_definition h_empty' :: "(('state \<times> 'input), ('output \<times> 'state)) set_mapping" is h_empty done

fun fsm_from_list :: "'state \<Rightarrow> ('state \<times> 'input \<times> 'output 'state) list \<Rightarrow> ('state, 'input, 'output) fsm" where
  "

end (*

record ('state, 'input, 'output) fsm_impl =
  initial_impl :: 'state
  nodes_impl :: "'state set"
  inputs_impl  :: "'input set"
  outputs_impl  :: "'output set"
  h_impl :: "('state \<times> 'input) \<rightharpoonup> (('output \<times> 'state) set)"

fun f_impl :: "('state, 'input, 'output) fsm_impl \<Rightarrow> bool" where
  "f_impl M = False"

typedef ('state, 'input, 'output) fsm = "{ M :: ('state, 'input, 'output) fsm_impl . initial_impl M \<in> nodes_impl M
\<and> finite (nodes_impl M)
\<and> finite (inputs_impl M)
\<and> finite (outputs_impl M)
\<and> (\<forall> (q,x) \<in> dom (h_impl M) . q \<in> nodes_impl M \<and> x \<in> inputs_impl M)
\<and> (\<forall> S \<in> ran (h_impl M) . \<forall> (y,q') \<in> S . q' \<in> nodes_impl M \<and> y \<in> outputs_impl M)}"
  morphisms fsm_impl Fsm
proof -
  obtain q :: 'state where "True" by blast
  define M :: "('state, 'input, 'output) fsm_impl" where "M = \<lparr> initial_impl = q, nodes_impl = {q}, inputs_impl = {}, outputs_impl = {}, h_impl = Map.empty \<rparr>"
  then have "initial_impl M \<in> nodes_impl M
              \<and> finite (nodes_impl M)
              \<and> finite (inputs_impl M)
              \<and> finite (outputs_impl M)
              \<and> (\<forall> (q,x) \<in> dom (h_impl M) . q \<in> nodes_impl M \<and> x \<in> inputs_impl M)
              \<and> (\<forall> S \<in> ran (h_impl M) . \<forall> (y,q') \<in> S . q' \<in> nodes_impl M \<and> y \<in> outputs_impl M)"
    by auto
  then show ?thesis by blast
qed

setup_lifting type_definition_fsm

lift_definition initial :: "('state, 'input, 'output) fsm \<Rightarrow> 'state" is initial_impl done
lift_definition nodes :: "('state, 'input, 'output) fsm \<Rightarrow> 'state set" is nodes_impl done
lift_definition inputs :: "('state, 'input, 'output) fsm \<Rightarrow> 'input set" is inputs_impl done
lift_definition outputs :: "('state, 'input, 'output) fsm \<Rightarrow> 'output set" is outputs_impl done
lift_definition h :: "('state, 'input, 'output) fsm \<Rightarrow> ('state \<times> 'input) \<rightharpoonup> (('output \<times> 'state) set)" is h_impl done

lift_definition f :: "('state, 'input, 'output) fsm \<Rightarrow> bool" is EXP.f_impl done

definition M :: "(nat,nat,nat) fsm_impl" where
  "M = \<lparr> initial_impl = 0, nodes_impl = {0,1,2}, inputs_impl = {0}, outputs_impl = {0,1}, h_impl = Map.empty \<rparr>"

lemma "initial_impl M \<in> nodes_impl M
              \<and> finite (nodes_impl M)
              \<and> finite (inputs_impl M)
              \<and> finite (outputs_impl M)
              \<and> (\<forall> (q,x) \<in> dom (h_impl M) . q \<in> nodes_impl M \<and> x \<in> inputs_impl M)
              \<and> (\<forall> S \<in> ran (h_impl M) . \<forall> (y,q') \<in> S . q' \<in> nodes_impl M \<and> y \<in> outputs_impl M)" unfolding M_def by force
value "M"

value "initial_impl M"
lemma "initial_impl M = initial (Fsm M)"
proof -
  have "initial_impl M \<in> nodes_impl M
              \<and> finite (nodes_impl M)
              \<and> finite (inputs_impl M)
              \<and> finite (outputs_impl M)
              \<and> (\<forall> (q,x) \<in> dom (h_impl M) . q \<in> nodes_impl M \<and> x \<in> inputs_impl M)
              \<and> (\<forall> S \<in> ran (h_impl M) . \<forall> (y,q') \<in> S . q' \<in> nodes_impl M \<and> y \<in> outputs_impl M)" unfolding M_def by force
  then show ?thesis

value "initial (Fsm M)"

end


           (*-------------------------------------------*
            |        CSP-Prover on Isabelle2004         |
            |               December 2004               |
            |                 August 2005  (modified)   |
            |                                           |
            |        CSP-Prover on Isabelle2005         |
            |                October 2005  (modified)   |
            |                  April 2006  (modified)   |
            |                                           |
            |        CSP-Prover on Isabelle2012         |
            |               November 2012  (modified)   |
            |                                           |
            |        CSP-Prover on Isabelle2013         |
            |                   June 2013  (modified)   |
            |                                           |
            |        CSP-Prover on Isabelle2016         |
            |                    May 2016  (modified)   |
            |                                           |
            |        CSP-Prover on Isabelle2017         |
            |                  April 2018  (modified)   |
            |                                           |
            |        Yoshinao Isobe (AIST JAPAN)        |
            *-------------------------------------------*)

theory Set_F
imports CSP.Trace
begin

(*****************************************************************

         1.
         2.
         3.
         4.

 *****************************************************************)

(*  The following simplification rules are deleted in this theory file *)
(*  because they unexpectly rewrite UnionT and InterT.                 *)
(*                  Union (B ` A) = (UN x:A. B x)                      *)
(*                  Inter (B ` A) = (INT x:A. B x)                     *)

(*
declare Union_image_eq [simp del]
declare Inter_image_eq [simp del]
*)
(* no simp rules in Isabelle 2017
declare Sup_image_eq [simp del]
declare Inf_image_eq [simp del]
*)

(***********************************************************
                 type def (Failure Part)
 ***********************************************************)

(* types 'a failure = "'a trace * 'a event set"       (* synonym *)   Isabelle 2011 *)
type_synonym 'a failure = "'a trace * 'a event set"       (* synonym *)

definition
  HC_F2    :: "'a failure set => bool"
  where
  HC_F2_def : "HC_F2 F == (ALL s X Y. ((s,X) : F & Y <= X) --> (s,Y) : F)"

definition "setF  = {F::('a failure set). HC_F2(F)}"
typedef 'a setF = "setF :: 'a failure set set"
apply (rule_tac x ="{}" in exI)
apply (simp add: setF_def)
by (simp add: HC_F2_def)

declare Rep_setF         [simp]

(***********************************************************
                   operators on setF
 ***********************************************************)

definition
  memF     :: "'a failure => 'a setF => bool"  ("(_/ :f _)" [50, 51] 50)
  where
  memF_def     : "x :f F     == x : (Rep_setF F)"

definition
  CollectF :: "('a failure => bool) => 'a setF"("CollectF")
  where
  CollectF_def : "CollectF P == Abs_setF (Collect P)"

definition
  UnionF   :: "'a setF set => 'a setF"         ("UnionF _" [90] 90)
  where
  UnionF_def   : "UnionF Fs  == Abs_setF (Union (Rep_setF ` Fs))"

definition
  InterF   :: "'a setF set => 'a setF"         ("InterF _" [90] 90)
  where
  InterF_def   : "InterF Fs  == Abs_setF (Inter (Rep_setF ` Fs))"

definition
  empF     :: "'a setF"                        ("{}f")
  where
  empF_def     : "{}f        == Abs_setF {}"

definition
  UNIVF    :: "'a setF"                        ("UNIVf")
  where
  UNIVF_def    : "UNIVf      == Abs_setF UNIV"

(******** X-symbols ********)
(*
notation (xsymbols) memF ("(_/ \<in>f _)" [50, 51] 50)
notation (xsymbols) UnionF ("\<Union>f _" [90] 90)
notation (xsymbols) InterF ("\<Inter>f _" [90] 90)
*)

(******** syntactic sugar ********)

abbreviation
 nonmemF :: "'a failure => 'a setF => bool"   ("(_/ ~:f _)" [50, 51] 50)
 where "x ~:f F == ~ x :f F"

abbreviation
 UnF :: "'a setF => 'a setF => 'a setF"   ("_ UnF _" [65,66] 65)
 where "F UnF E == UnionF {F,E}"

abbreviation
 IntF :: "'a setF => 'a setF => 'a setF"   ("_ IntF _" [70,71] 70)
 where "F IntF E == InterF {F,E}"

syntax
  "@CollF"    :: "pttrn => bool => 'a setF"        ("(1{_./ _}f)" [1000,10] 1000)
  "@FinsetF"  :: "args => 'a setF"                 ("{(_)}f" [1000] 1000)

translations
  "{x. P}f"    == "CONST Abs_setF {x. P}" (* "CONST" for isabelle2009-2 *)
  "{X}f"       == "CONST Abs_setF {X}"    (* "CONST" for isabelle2009-2 *)

(******** X-symbols ********)
(*
notation (xsymbols) nonmemF  ("(_/ \<notin>f _)" [50, 51] 50)
notation (xsymbols) UnF      ("_ \<union>f _" [65,66] 65)
notation (xsymbols) IntF     ("_ \<inter>f _" [70,71] 70)
*)
(*********************************************************
          The relation (<=) is defined over setF
 *********************************************************)

instantiation setF :: (type) ord
begin
definition
  subsetF_def:
    "F <= E  ==  (Rep_setF F) <= (Rep_setF E)"
definition
  psubsetF_def:
    "F <  E  ==  (Rep_setF F) <  (Rep_setF E)"

instance
by (intro_classes)
end

(*********************************************************
          The relation (<=) is a partial order
 *********************************************************)

instance setF :: (type) order
apply (intro_classes)
apply (unfold subsetF_def psubsetF_def)
(* apply (simp add: less_fun_def)                (* isabelle 2009-2011 !! *)*)
apply (simp only: order_less_le Rep_setF_inject)
apply (auto simp add: Rep_setF_inject)
done

(***********************************************************
                          lemmas
 ***********************************************************)

(*******************************
             basic
 *******************************)

lemma setF_F2:
  "[| F : setF ; (s,X) : F ; Y <= X |] ==> (s,Y) : F"
apply (simp add: setF_def)
apply (unfold HC_F2_def)
apply (drule_tac x="s" in spec)
apply (drule_tac x="X" in spec)
apply (drule_tac x="Y" in spec)
by (simp)

(*** {} in setF ***)

lemma emptyset_in_setF[simp]: "{} : setF"
by (simp add: setF_def HC_F2_def)

(*******************************
         check in setF
 *******************************)

(*** [] (for STOP) ***)

lemma nilt_in_setF[simp]: "{(<>, X) |X. X <= EvsetTick} : setF"
by (auto simp add: setF_def HC_F2_def)

(*** [Tick] (for SKIP) ***)
lemma nilt_Tick_in_setF[simp]: "{(<>, X) |X. X <= Evset} Un
                                {(<Tick>, X) |X. X <= EvsetTick} : setF"
apply (simp add: setF_def HC_F2_def)
apply (intro allI impI)
apply (elim conjE disjE)
by (simp_all)

(*** Union ***)

lemma setF_Union_in_setF: "(Union (Rep_setF ` Fs)) : setF"
apply (simp add: setF_def HC_F2_def)
apply (intro allI impI)

apply (erule conjE)
apply (erule bexE)
apply (rename_tac s X Y F)
apply (rule_tac x="F" in bexI)
apply (rule setF_F2)
by (simp_all)

(*** Un ***)

lemma setF_Un_in_setF:
  "(Rep_setF F Un Rep_setF E) : setF"
apply (insert setF_Union_in_setF[of "{F,E}"])
by (simp)

(*** Inter ***)

lemma setF_Inter_in_setF: "(Inter (Rep_setF ` Fs)) : setF"
apply (simp add: setF_def HC_F2_def)
apply (intro allI impI)

apply (rule ballI)
apply (rename_tac s X Y F)
apply (erule conjE)
apply (drule_tac x="F" in bspec, simp)
apply (rule setF_F2)
by (simp_all)

(*** Int ***)

lemma setF_Int_in_setF:
  "(Rep_setF F Int Rep_setF E) : setF"
apply (insert setF_Inter_in_setF[of "{F,E}"])
by (simp)

lemmas in_setF = setF_Union_in_setF setF_Un_in_setF
                 setF_Inter_in_setF setF_Int_in_setF

(*******************************
     setF type --> set type
 *******************************)

(*** UnionF ***)

lemma setF_UnionF_Rep:
  "Rep_setF (UnionF Fs) = Union (Rep_setF ` Fs)"
by (simp add: UnionF_def Abs_setF_inverse in_setF)

(*** UnF ***)

lemma setF_UnF_Rep:
  "Rep_setF (F UnF E) = (Rep_setF F) Un (Rep_setF E)"
by (simp add: setF_UnionF_Rep)

(*** InterF ***)

lemma setF_InterF_Rep:
  "Rep_setF (InterF Fs) = Inter (Rep_setF ` Fs)"
by (simp add: InterF_def Abs_setF_inverse in_setF)

(*** IntF ***)

lemma setF_IntF_Rep:
  "Rep_setF (F IntF E) = (Rep_setF F) Int (Rep_setF E)"
by (simp add: setF_InterF_Rep)

(*********************************************************
                       memF
 *********************************************************)

(* memF_F2 *)

lemma memF_F2:
  "[| (s,X) :f F ; Y <= X |] ==> (s,Y) :f F"
apply (simp add: memF_def)
apply (rule setF_F2)
by (simp_all)

(* UnionF *)

lemma memF_UnionF_only_if:
  "sX :f UnionF Fs ==> EX F:Fs. sX :f F"
by (simp add: memF_def setF_UnionF_Rep)

lemma memF_UnionF_if:
  "[| F:Fs ; sX :f F |] ==> sX :f UnionF Fs"
apply (subgoal_tac "Fs ~= {}")
apply (simp add: memF_def setF_UnionF_Rep)
apply (rule_tac x="F" in bexI)
by (auto)

lemma memF_UnionF[simp]:
  "sX :f UnionF Fs = (EX F:Fs. sX :f F)"
apply (rule iffI)
apply (simp add: memF_UnionF_only_if)
by (auto simp add: memF_UnionF_if)

(* InterF *)

lemma memF_InterF_only_if:
  "sX :f InterF Fs ==> ALL F:Fs. sX :f F"
by (simp add: memF_def setF_InterF_Rep)

lemma memF_InterF_if:
  "ALL F:Fs. sX :f F ==> sX :f InterF Fs"
by (simp add: memF_def setF_InterF_Rep)

lemma memF_InterF[simp]:
  "sX :f InterF Fs = (ALL F:Fs. sX :f F)"
apply (rule iffI)
apply (rule memF_InterF_only_if, simp_all)
by (simp add: memF_InterF_if)

(* empty *)

lemma memF_empF[simp]: "sX ~:f {}f"
apply (simp add: memF_def empF_def)
by (simp add: Abs_setF_inverse)

(* pair *)

lemma memF_pair_iff: "(f :f F) = (EX s X. f = (s,X) & (s,X) :f F)"
apply (rule)
apply (rule_tac x="fst f" in exI)
apply (rule_tac x="snd f" in exI)
by (auto)

lemma memF_pairI: "(EX s X. f = (s,X) & (s,X) :f F) ==> (f :f F)"
by (auto)

lemma memF_pairE_lm: "[| f :f F ; (EX s X. f = (s,X) & (s,X) :f F) --> R |] ==> R"
apply (drule mp)
apply (rule_tac x="fst f" in exI)
apply (rule_tac x="snd f" in exI)
by (auto)

lemma memF_pairE: "[| f :f F ; !! s X. [| f = (s,X) ; (s,X) :f F |] ==> R |] ==> R"
apply (erule memF_pairE_lm)
by (auto)

(*********************************************************
                       subsetF
 *********************************************************)

lemma subsetFI [intro!]: "(!! s X. (s, X) :f E ==> (s, X) :f F) ==> E <= F"
by (auto simp add: subsetF_def memF_def)

lemma subsetFE [elim!]:
  "[| E <= F ; (!!s X. (s, X) :f E ==> (s, X) :f F) ==> R |] ==> R"
by (auto simp add: subsetF_def memF_def)

lemma subsetFE_ALL:
  "[| E <= F ; (ALL s X. (s, X) :f E --> (s, X) :f F) ==> R |] ==> R"
by (auto simp add: subsetF_def memF_def)

lemma subsetF_iff: "((E::'a setF) <= F)
                  = (ALL s X. (s, X) :f E --> (s, X) :f F)"
by (auto)

(*** {}f is bottom ***)

lemma BOT_is_bottom_setF[simp]: "{}f <= F"
by (simp add: subsetF_iff)

lemma memF_subsetF: "[| (s,X) :f E ; E <= F |] ==> (s,X) :f F"
by (simp add: subsetF_iff)

(*********************************************************
                         UnF
 *********************************************************)

lemma UnF_commut: "E UnF F = F UnF E"
apply (rule order_antisym)
by (simp_all add: subsetF_iff)

lemma UnF_assoc: "(E UnF F) UnF R = E UnF (F UnF R)"
apply (rule order_antisym)
by (simp_all add: subsetF_iff)

lemma UnF_left_commut: "E UnF (F UnF R) = F UnF (E UnF R)"
apply (rule order_antisym)
by (simp_all add: subsetF_iff)

lemmas UnF_rules = UnF_commut UnF_assoc UnF_left_commut

(*********************************************************
                         IntF
 *********************************************************)

lemma IntF_commut: "E IntF F = F IntF E"
apply (rule order_antisym)
by (simp_all add: subsetF_iff)

lemma IntF_assoc: "(E IntF F) IntF R = E IntF (F IntF R)"
apply (rule order_antisym)
by (simp_all add: subsetF_iff)

lemma IntF_left_commut: "E IntF (F IntF R) = F IntF (E IntF R)"
apply (rule order_antisym)
by (simp_all add: subsetF_iff)

lemmas IntF_rules = IntF_commut IntF_assoc IntF_left_commut

(*********************************************************
                         CollectT
 *********************************************************)

(*** open ***)

lemma CollectF_open[simp]: "{u. u :f F}f = F"
apply (subgoal_tac "{f. f :f F} : setF")
apply (auto simp add: memF_def Abs_setF_inverse)
by (simp add: Rep_setF_inverse)

lemma CollectF_open_memF: "{f. P f} : setF ==> f :f {f. P f}f = P f"
by (simp add: memF_def Abs_setF_inverse)

(*** implies {  }f ***)

lemma set_CollectF_eq:
  "{f. Pr1 f} = {f. Pr2 f} ==>{f. Pr1 f}f = {f. Pr2 f}f"
by (simp)

lemma CollectF_eq:
  "[| !! f. Pr1 f = Pr2 f |] ==>{f. Pr1 f}f = {f. Pr2 f}f"
by (simp)

(****************** to add them again ******************)
(*
declare Union_image_eq [simp]
declare Inter_image_eq [simp]
*)
(*
declare Sup_image_eq [simp]
declare Inf_image_eq [simp]
*)
end


section \<open>Three-step Optimized MRU Model\<close>
theory Three_Step_MRU
imports "../MRU_Vote_Opt" Three_Steps
begin

text \<open>To make the coming proofs of concrete algorithms easier, in this model we split
  the @{term opt_mru_round} into three steps\<close>

subsection \<open>Model definition\<close>
(******************************************************************************)
record three_step_mru_state = opt_mru_state +
  candidates :: "val set"

context mono_quorum
begin

definition opt_mru_step0 :: "round \<Rightarrow> val set \<Rightarrow>  (three_step_mru_state \<times> three_step_mru_state) set" where
  "opt_mru_step0 r C = {(s, s').
     \<comment> \<open>guards\<close>
     r = next_round s \<and> three_step r = 0
     \<and> (\<forall>cand \<in> C. \<exists>Q. opt_mru_guard (mru_vote s) Q cand)
     \<and> \<comment> \<open>actions\<close>
     s' = s\<lparr>
       candidates := C
       , next_round := Suc r
     \<rparr>
  }"

definition opt_mru_step1 :: "round \<Rightarrow> process set \<Rightarrow> val \<Rightarrow>
  (three_step_mru_state \<times> three_step_mru_state) set" where
  "opt_mru_step1 r S v = {(s, s').
     \<comment> \<open>guards\<close>
     r = next_round s \<and> three_step r = 1
     \<and> (S \<noteq> {} \<longrightarrow> v \<in> candidates s)
     \<and> \<comment> \<open>actions\<close>
     s' = s\<lparr>
       mru_vote := mru_vote s ++ const_map (three_phase r, v) S
       , next_round := Suc r
     \<rparr>
  }"

definition step2_d_guard :: "(process, val)map \<Rightarrow> (process, val)map \<Rightarrow> bool" where
  "step2_d_guard r_decisions r_votes \<equiv> \<forall>p v. r_decisions p = Some v \<longrightarrow>
      v \<in> ran r_votes \<and> dom r_votes \<in> Quorum"

definition r_votes :: "three_step_mru_state \<Rightarrow> round \<Rightarrow> (process, val)map" where
  "r_votes s r \<equiv> \<lambda>p. if (\<exists>v. mru_vote s p = Some (three_phase r, v))
        then map_option snd (mru_vote s p)
        else None"

definition opt_mru_step2 :: "round \<Rightarrow> (process, val)map \<Rightarrow> (three_step_mru_state \<times> three_step_mru_state) set" where
  "opt_mru_step2 r r_decisions = {(s, s').
     \<comment> \<open>guards\<close>
     r = next_round s \<and> three_step r = 2
     \<and> step2_d_guard r_decisions  (r_votes s r)
     \<and> \<comment> \<open>actions\<close>
     s' = s\<lparr>
       next_round := Suc r
       , decisions := decisions s ++ r_decisions
     \<rparr>
  }"

lemmas ts_mru_evt_defs = opt_mru_step0_def opt_mru_step1_def opt_mru_guard_def

definition ts_mru_trans :: "(three_step_mru_state \<times> three_step_mru_state) set" where
  "ts_mru_trans = (\<Union>r C. opt_mru_step0 r C)
      \<union> (\<Union>r S v. opt_mru_step1 r S v)
      \<union> (\<Union>r dec_f. opt_mru_step2 r dec_f) \<union> Id"

definition ts_mru_init where
  "ts_mru_init = { \<lparr> next_round = 0, mru_vote = Map.empty, decisions = Map.empty, candidates = {} \<rparr> }"

definition ts_mru_TS :: "three_step_mru_state TS" where
  "ts_mru_TS = \<lparr> init = ts_mru_init, trans = ts_mru_trans \<rparr>"

lemmas ts_mru_TS_defs = ts_mru_TS_def ts_mru_init_def ts_mru_trans_def

subsection \<open>Refinement\<close>
(******************************************************************************)

definition basic_rel where
  "basic_rel \<equiv> {(sa, sc).
    decisions sc = decisions sa
    \<and> next_round sa = three_phase (next_round sc)
  }"

definition three_step0_rel :: "(opt_mru_state \<times> three_step_mru_state)set" where
  "three_step0_rel \<equiv> basic_rel \<inter> {(sa, sc).
    three_step (next_round sc) = 0
    \<and> mru_vote sc = mru_vote sa
  }"

definition three_step1_rel :: "(opt_mru_state \<times> three_step_mru_state)set"  where
  "three_step1_rel \<equiv> basic_rel \<inter> {(sa, sc).
    (\<exists>sc' r C. (sa, sc') \<in> three_step0_rel \<and> (sc', sc) \<in> opt_mru_step0 r C)
    \<and> mru_vote sc = mru_vote sa
  }"

definition three_step2_rel :: "(opt_mru_state \<times> three_step_mru_state)set"  where
  "three_step2_rel \<equiv> basic_rel \<inter> {(sa, sc).
    (\<exists>sc' r S v. (sa, sc') \<in> three_step1_rel \<and> (sc', sc) \<in> opt_mru_step1 r S v)
  }"

definition ts_ref_rel where
  "ts_ref_rel = {(sa, sc).
    (three_step (next_round sc) = 0 \<longrightarrow> (sa, sc) \<in> three_step0_rel)
    \<and> (three_step (next_round sc) = 1 \<longrightarrow> (sa, sc) \<in> three_step1_rel)
    \<and> (three_step (next_round sc) = 2 \<longrightarrow> (sa, sc) \<in> three_step2_rel)
  }"

lemmas ts_ref_rel_defs =
  basic_rel_def
  ts_ref_rel_def
  three_step0_rel_def
  three_step1_rel_def
  three_step2_rel_def

lemma step0_ref:
  "{ts_ref_rel} Id, opt_mru_step0 r C {> ts_ref_rel}"
proof(simp only: PO_rhoare_defs, safe)
  fix sa sc sc'
  assume R: "(sa, sc) \<in> ts_ref_rel" and step: "(sc, sc') \<in> opt_mru_step0 r C"
  hence r_step: "three_step (next_round sc) = 0" "three_step (next_round sc') = 1"
    by(auto simp add: ts_ref_rel_def opt_mru_step0_def three_step_Suc)
  hence "(sa, sc') \<in> ts_ref_rel" using R step
    apply(auto simp add: ts_ref_rel_def  three_step_phase_Suc three_step1_rel_def
      three_step2_rel_def intro!: exI[where x=sc] step R)
     apply(auto simp add: three_step0_rel_def basic_rel_def three_step_phase_Suc
        opt_mru_step0_def)
    done
  thus "\<exists>sa'. (sa, sa') \<in> Id \<and> (sa', sc') \<in> ts_ref_rel"
    by blast
qed

lemma step1_ref:
  "{ts_ref_rel} Id, opt_mru_step1 r S v {> ts_ref_rel}"
proof(simp only: PO_rhoare_defs, safe)
  fix sa sc sc'
  assume R: "(sa, sc) \<in> ts_ref_rel" and step: "(sc, sc') \<in> opt_mru_step1 r S v"
  hence r_step: "three_step (next_round sc) = 1" "three_step (next_round sc') = 2"
    by(auto simp add: ts_ref_rel_def opt_mru_step1_def three_step_Suc)
  hence "(sa, sc') \<in> ts_ref_rel" using R step
    apply(auto simp add: ts_ref_rel_def  three_step_phase_Suc three_step0_rel_def
      three_step2_rel_def intro!: exI[where x=sc] step R)
    apply(auto simp add: three_step1_rel_def basic_rel_def three_step_phase_Suc
      opt_mru_step1_def)
    done
  thus "\<exists>sa'. (sa, sa') \<in> Id \<and> (sa', sc') \<in> ts_ref_rel"
    by blast
qed

  from R step2 obtain sc0 r0 C sc1 r1 S v where
    R0: "(sa, sc0) \<in> three_step0_rel" and step0: "(sc0, sc1) \<in> opt_mru_step0 r0 C"
    and R1: "(sa, sc1) \<in> three_step1_rel" and step1: "(sc1, sc2) \<in> opt_mru_step1 r1 S v"
    by(fastforce simp add: ts_ref_rel_def three_step2_rel_def opt_mru_step2_def
      three_step1_rel_def)

  have R2: "(sa, sc2) \<in> three_step2_rel"
    and r2_step: "three_step (next_round sc2) = Suc (Suc 0)"
    and r3_step: "three_step (next_round sc3) = 0"
    using R step2
    by(auto simp add: ts_ref_rel_def opt_mru_step2_def three_step_phase_Suc three_step_Suc)

  have r: "r = Suc r1" and r1: "r1 = Suc r0" "r1 = next_round sc1" and
    r0: "r0 = next_round sc0" and r0_step: "three_step r0 = 0" and
    r2: "r = next_round sc2"
    using step0 step1 step2
    by(auto simp add: opt_mru_step0_def opt_mru_step1_def opt_mru_step2_def)

  have abs_round2: "next_round sa = three_phase r" using R2 r2
    by(auto simp add: three_step2_rel_def basic_rel_def)
  have abs_round1: "next_round sa = three_phase r1" using R1 r1
    by(auto simp add: three_step1_rel_def basic_rel_def)
  have abs_round0: "next_round sa = three_phase r0" using R0 r0 r
    by(auto simp add: three_step0_rel_def basic_rel_def three_step_phase_Suc)

  have r_votes: "r_votes sc2 r = const_map v S"
  proof(rule ext)
    fix p
    show "r_votes sc2 r p = const_map v S p"
    proof(cases "r_votes sc2 r p")
      case None
      thus ?thesis using step0 step1 abs_round0 abs_round1 abs_round2
        by(auto simp add: r_votes_def opt_mru_step1_def
          const_map_def restrict_map_def map_add_def)
    next
      case (Some w)
      hence in_S: "mru_vote sc1 p \<noteq> mru_vote sc2 p" using R0 step0 ainv r1 r abs_round0
        by(auto simp add: r_votes_def ts_ref_rel_defs
          three_step_phase_Suc opt_mru_step0_def dest: OMRU_inv1D[where p=p])
      hence "p \<in> S"  using step1
        by(auto simp add: opt_mru_step1_def map_add_def const_map_is_Some
          split: option.split_asm)
      moreover have "w=v" using R0 R1 step1 ainv r abs_round1 Some
        by(auto simp add: r_votes_def ts_ref_rel_defs const_map_is_Some
          three_step_phase_Suc opt_mru_step1_def dest: OMRU_inv1D[where p=p])
      ultimately show ?thesis using Some
        by(auto simp add: const_map_def)
    qed
  qed

  from step0 step1 obtain Q where Q: "S \<noteq> {} \<longrightarrow> opt_mru_guard (mru_vote sc0) Q v"
    by(auto simp add: opt_mru_step0_def opt_mru_step1_def)

  define sa' where "sa' = sa\<lparr>
      mru_vote := mru_vote sa ++ const_map (three_phase r, v) S
      , next_round := Suc (three_phase r)
      , decisions := decisions sa ++ dec_f
    \<rparr>"

  have guard_strengthening:
    "step2_d_guard dec_f (r_votes sc2 r) \<longrightarrow> d_guard dec_f (const_map v S)"
    by(auto simp add: r_votes d_guard_def step2_d_guard_def locked_in_vf_def
      quorum_for_def const_map_is_Some dom_const_map)
  have "(sa, sa') \<in> opt_mru_round (three_phase r) Q S v dec_f \<and> (sa', sc3) \<in> ts_ref_rel"
  proof
    show "(sa', sc3) \<in> ts_ref_rel" using r3_step R0 R1 R2 step0 step1 step2
      by(auto simp add: ts_ref_rel_def three_step0_rel_def basic_rel_def opt_mru_step0_def
        opt_mru_step1_def opt_mru_step2_def  sa'_def three_step_phase_Suc)
  next
    show "(sa, sa') \<in> opt_mru_round (three_phase r) Q S v dec_f"
      using R0 r0_step step0 step1 step2 r0 r1 r2 r r_votes Q guard_strengthening
      by(auto simp add: ts_ref_rel_defs opt_mru_round_def three_step_phase_Suc
        opt_mru_step0_def opt_mru_step1_def opt_mru_step2_def sa'_def)
  qed
  thus "\<exists>y. (sa, y) \<in> (\<Union>r' Q S' v D'. opt_mru_round r' Q S' v D') \<and> (y, sc3) \<in> ts_ref_rel"
    by simp blast
qed

lemma ThreeStep_Coordinated_Refines:
  "PO_refines (ts_ref_rel \<inter> OMRU_inv1 \<times> UNIV)
    mru_opt_TS ts_mru_TS"
proof(rule refine_using_invariants)
  show "init ts_mru_TS \<subseteq> ts_ref_rel `` init mru_opt_TS"
    by(auto simp add: ts_mru_TS_defs mru_opt_TS_defs ts_ref_rel_def three_step0_rel_def
      three_step1_rel_def three_step2_rel_def basic_rel_def)
next
  show
    "{ts_ref_rel \<inter> OMRU_inv1 \<times> UNIV} TS.trans mru_opt_TS,
      TS.trans (ts_mru_TS) {> ts_ref_rel}"
    apply(simp add: mru_opt_TS_defs ts_mru_TS_defs)
    apply(auto simp add: ts_mru_trans_def intro!: step0_ref step1_ref step2_ref)
    done
qed(auto intro!: OMRU_inv1_inductive)

end

end


           (*-------------------------------------------*
            |        CSP-Prover on Isabelle2004         |
            |                    May 2005               |
            |                   June 2005  (modified)   |
            |              September 2005  (modified)   |
            |                                           |
            |        CSP-Prover on Isabelle2005         |
            |                October 2005  (modified)   |
            |                  April 2006  (modified)   |
            |                  March 2007  (modified)   |
            |                                           |
            |        CSP-Prover on Isabelle2017         |
            |                  April 2018  (modified)   |
            |                                           |
            |        Yoshinao Isobe (AIST JAPAN)        |
            *-------------------------------------------*)

theory CSP_T_law_alpha_par
imports CSP_T_op_alpha_par CSP_T_law_decompo
begin

(*  The following simplification rules are deleted in this theory file *)
(*  because they unexpectly rewrite UnionT and InterT.                 *)
(*                  Union (B ` A) = (UN x:A. B x)                      *)
(*                  Inter (B ` A) = (INT x:A. B x)                     *)

(* Isabelle 2013
declare Union_image_eq [simp del]
declare Inter_image_eq [simp del]
*)
(* no simp rules in Isabelle 2017
declare Sup_image_eq [simp del]
declare Inf_image_eq [simp del]
*)

(*****************************************************************

         1. associativity of |[X,Y]|
         2. commutativity of |[X,Y]|
         3. monotonicity of |[X,Y]|
         4.

 *****************************************************************)

(*********************************************************
                        P |[X,Y]| Q
 *********************************************************)

(************************************
 |         SKIP and SKIP            |
 ************************************)

(*------------------*
 |      csp law     |
 *------------------*)

lemma cspT_SKIP_Alpha_parallel:
  "(SKIP |[{}, {}]| SKIP) =T[M1,M2] SKIP"
apply (simp add: cspT_semantics)
apply (rule order_antisym)

(* => *)
 apply (rule)
 apply (simp add: in_traces in_traces_Alpha_parallel)
 apply (simp add: sett_subset_Tick)

(* <= *)
 apply (rule)
 apply (simp add: in_traces in_traces_Alpha_parallel)
 apply (simp add: sett_subset_Tick)
 apply (insert rest_tr_sett_subseteq_sett[of _ "{}"])
 apply (auto)
done

(************************************
 |          associativity           |
 ************************************)

(*------------------*
 |      csp law     |
 *------------------*)

lemma cspT_Alpha_parallel_assoc:
  "(P1 |[X1, X2]| P2) |[X1 Un X2, X3]| P3 =T[M,M]
   P1 |[X1, X2 Un X3]| (P2 |[X2, X3]| P3)"
apply (simp add: cspT_semantics)
apply (rule order_antisym)

(* => *)
 apply (rule)
 apply (simp add: in_traces_Alpha_parallel)
 apply (elim conjE exE)
 apply (simp add: Un_upper1 Un_upper2 rest_tr_of_rest_tr_subset)
 apply (simp add: Un_assoc)

(* <= *)
 apply (rule)
 apply (simp add: in_traces_Alpha_parallel)
 apply (elim conjE exE)
 apply (simp add: Un_upper1 Un_upper2 rest_tr_of_rest_tr_subset)
 apply (simp add: Un_assoc)
done

lemma cspT_Alpha_parallel_assoc_sym:
  "P1 |[X1, X2 Un X3]| (P2 |[X2, X3]| P3) =T[M,M]
   (P1 |[X1, X2]| P2) |[X1 Un X2, X3]| P3"
apply (rule cspT_sym)
by (simp add: cspT_Alpha_parallel_assoc)

(************************************
 |          commutativity           |
 ************************************)

(*------------------*
 |      csp law     |
 *------------------*)

lemma cspT_Alpha_parallel_commut:
  "(P1 |[X1, X2]| P2) =T[M,M] (P2 |[X2, X1]| P1)"
apply (simp add: cspT_semantics)
apply (rule order_antisym)

(* => *)
 apply (rule)
 apply (simp add: in_traces_Alpha_parallel)
 apply (fast)

(* <= *)
 apply (rule)
 apply (simp add: in_traces_Alpha_parallel)
 apply (fast)
done

(************************************
 |          monotonicity            |
 ************************************)

(*------------------*
 |      csp law M   |
 *------------------*)

lemma cspT_Alpha_parallel_mono:
  "[| X1 = X2 ; Y1 = Y2 ;
      P1 <=T[M1,M2] Q1 ;
      P2 <=T[M1,M2] Q2 |]
           ==> P1 |[X1,Y1]| P2 <=T[M1,M2] Q1 |[X2,Y2]| Q2"
apply (simp add: Alpha_parallel_def)
apply (simp add: cspT_Parallel_mono)
done

lemma cspT_Alpha_parallel_cong:
  "[| X1 = X2 ; Y1 = Y2 ;
      P1 =T[M1,M2] Q1 ;
      P2 =T[M1,M2] Q2 |]
           ==> P1 |[X1,Y1]| P2 =T[M1,M2] Q1 |[X2,Y2]| Q2"
by (simp add: cspT_eq_ref_iff cspT_Alpha_parallel_mono)

lemmas cspT_decompo_Alpha_parallel = cspT_Alpha_parallel_mono
                                     cspT_Alpha_parallel_cong

(****************** to add them again ******************)
(* 2013
declare Union_image_eq [simp]
declare Inter_image_eq [simp]
*)
(* 2017
declare Sup_image_eq [simp]
declare Inf_image_eq [simp]
*)
end


section \<open>Implementations of the SPYH-Method\<close>

theory SPYH_Method_Implementations
imports Intermediate_Frameworks
begin

subsection \<open>Using the H-Framework\<close>

definition spyh_method_via_h_framework :: "('a::linorder,'b::linorder,'c::linorder) fsm \<Rightarrow> nat \<Rightarrow> bool \<Rightarrow> bool \<Rightarrow> ('b\<times>'c) prefix_tree" where
  "spyh_method_via_h_framework = h_framework_dynamic (\<lambda> M V t X l . True)"

definition spyh_method_via_h_framework_lists :: "('a::linorder,'b::linorder,'c::linorder) fsm \<Rightarrow> nat \<Rightarrow> bool \<Rightarrow> bool \<Rightarrow> (('b\<times>'c) \<times> bool) list list" where
  "spyh_method_via_h_framework_lists M m completeInputTraces useInputHeuristic = sorted_list_of_maximal_sequences_in_tree (test_suite_from_io_tree M (initial M) (spyh_method_via_h_framework M m completeInputTraces useInputHeuristic))"

lemma spyh_method_via_h_framework_completeness_and_finiteness :
  fixes M1 :: "('a::linorder,'b::linorder,'c::linorder) fsm"
  fixes M2 :: "('e,'b,'c) fsm"
  assumes "observable M1"
  and     "observable M2"
  and     "minimal M1"
  and     "minimal M2"
  and     "size_r M1 \<le> m"
  and     "size M2 \<le> m"
  and     "inputs M2 = inputs M1"
  and     "outputs M2 = outputs M1"
shows "(L M1 = L M2) \<longleftrightarrow> ((L M1 \<inter> set (spyh_method_via_h_framework M1 m completeInputTraces useInputHeuristic)) = (L M2 \<inter> set (spyh_method_via_h_framework M1 m completeInputTraces useInputHeuristic)))"
and "finite_tree (spyh_method_via_h_framework M1 m completeInputTraces useInputHeuristic)"
  using h_framework_dynamic_completeness_and_finiteness[OF assms]
  unfolding spyh_method_via_h_framework_def
  by blast+

lemma spyh_method_via_h_framework_lists_completeness :
  fixes M1 :: "('a::linorder,'b::linorder,'c::linorder) fsm"
  fixes M2 :: "('d,'b,'c) fsm"
  assumes "observable M1"
  and     "observable M2"
  and     "minimal M1"
  and     "minimal M2"
  and     "size_r M1 \<le> m"
  and     "size M2 \<le> m"
  and     "inputs M2 = inputs M1"
  and     "outputs M2 = outputs M1"
shows "(L M1 = L M2) \<longleftrightarrow> list_all (passes_test_case M2 (initial M2)) (spyh_method_via_h_framework_lists M1 m completeInputTraces useInputHeuristic)"
  using h_framework_dynamic_lists_completeness[OF assms]
  unfolding spyh_method_via_h_framework_lists_def h_framework_dynamic_lists_def spyh_method_via_h_framework_def
  by blast

subsection \<open>Using the SPY-Framework\<close>

definition spyh_method_via_spy_framework :: "('a::linorder,'b::linorder,'c::linorder) fsm \<Rightarrow> nat \<Rightarrow> bool \<Rightarrow> bool \<Rightarrow> ('b\<times>'c) prefix_tree" where
  "spyh_method_via_spy_framework M1 m completeInputTraces useInputHeuristic =
    spy_framework M1
                   get_state_cover_assignment
                   (handle_state_cover_dynamic completeInputTraces useInputHeuristic (get_distinguishing_sequence_from_ofsm_tables M1))
                   sort_unverified_transitions_by_state_cover_length
                   (establish_convergence_dynamic completeInputTraces useInputHeuristic (get_distinguishing_sequence_from_ofsm_tables M1))
                   (handle_io_pair completeInputTraces useInputHeuristic)
                   simple_cg_initial
                   simple_cg_insert
                   simple_cg_lookup_with_conv
                   simple_cg_merge
                   m"

lemma spyh_method_via_spy_framework_completeness_and_finiteness :
  fixes M1 :: "('a::linorder,'b::linorder,'c::linorder) fsm"
  fixes M2 :: "('d,'b,'c) fsm"
  assumes "observable M1"
  and     "observable M2"
  and     "minimal M1"
  and     "minimal M2"
  and     "size_r M1 \<le> m"
  and     "size M2 \<le> m"
  and     "inputs M2 = inputs M1"
  and     "outputs M2 = outputs M1"
shows "(L M1 = L M2) \<longleftrightarrow> ((L M1 \<inter> set (spyh_method_via_spy_framework M1 m completeInputTraces useInputHeuristic)) = (L M2 \<inter> set (spyh_method_via_spy_framework M1 m completeInputTraces useInputHeuristic)))"
and "finite_tree (spyh_method_via_spy_framework M1 m completeInputTraces useInputHeuristic)"
  using spy_framework_completeness_and_finiteness[OF assms,
                                                of get_state_cover_assignment
                                                   sort_unverified_transitions_by_state_cover_length ,
                                                OF get_state_cover_assignment_is_state_cover_assignment
                                                   sort_unverified_transitions_by_state_cover_length_retains_set[of _ M1 get_state_cover_assignment]
                                                   simple_cg_initial_invar_with_conv[OF assms(1,2)]
                                                   simple_cg_insert_invar_with_conv[OF assms(1,2)]
                                                   simple_cg_merge_invar_with_conv[OF assms(1,2)]
                                                   handle_state_cover_dynamic_separates_state_cover[OF get_distinguishing_sequence_from_ofsm_tables_distinguishes[OF assms(1,3)], of completeInputTraces useInputHeuristic M2 simple_cg_initial simple_cg_insert simple_cg_lookup_with_conv]
                                                   establish_convergence_dynamic_verifies_transition[of M1 "(get_distinguishing_sequence_from_ofsm_tables M1)" completeInputTraces useInputHeuristic M2 _ _ simple_cg_insert simple_cg_lookup_with_conv, OF get_distinguishing_sequence_from_ofsm_tables_distinguishes[OF assms(1,3)]]
                                                   handle_io_pair_verifies_io_pair[of completeInputTraces useInputHeuristic M1 M2 simple_cg_insert simple_cg_lookup_with_conv]
                                                ]
    unfolding spyh_method_via_spy_framework_def[symmetric]
    by presburger+

definition spyh_method_via_spy_framework_lists :: "('a::linorder,'b::linorder,'c::linorder) fsm \<Rightarrow> nat \<Rightarrow> bool \<Rightarrow> bool \<Rightarrow> (('b\<times>'c) \<times> bool) list list" where
  "spyh_method_via_spy_framework_lists M m completeInputTraces useInputHeuristic = sorted_list_of_maximal_sequences_in_tree (test_suite_from_io_tree M (initial M) (spyh_method_via_spy_framework M m completeInputTraces useInputHeuristic))"

lemma spyh_method_via_spy_framework_lists_completeness :
  fixes M1 :: "('a::linorder,'b::linorder,'c::linorder) fsm"
  fixes M2 :: "('d,'b,'c) fsm"
  assumes "observable M1"
  and     "observable M2"
  and     "minimal M1"
  and     "minimal M2"
  and     "size_r M1 \<le> m"
  and     "size M2 \<le> m"
  and     "inputs M2 = inputs M1"
  and     "outputs M2 = outputs M1"
shows "(L M1 = L M2) \<longleftrightarrow> list_all (passes_test_case M2 (initial M2)) (spyh_method_via_spy_framework_lists M1 m completeInputTraces useInputHeuristic)"
  unfolding spyh_method_via_spy_framework_lists_def
            spyh_method_via_spy_framework_completeness_and_finiteness(1)[OF assms, of completeInputTraces useInputHeuristic]
            passes_test_cases_from_io_tree[OF assms(1,2) fsm_initial fsm_initial spyh_method_via_spy_framework_completeness_and_finiteness(2)[OF assms]]
  by blast

subsection \<open>Code Generation\<close>

(* one-time pre-computation of OFSM tables *)
lemma spyh_method_via_spy_framework_code[code] :
  "spyh_method_via_spy_framework M1 m completeInputTraces useInputHeuristic = (let
      tables = (compute_ofsm_tables M1 (size M1 - 1));
      distMap = mapping_of (map (\<lambda> (q1,q2) . ((q1,q2), get_distinguishing_sequence_from_ofsm_tables_with_provided_tables tables M1 q1 q2))
                        (filter (\<lambda> qq . fst qq \<noteq> snd qq) (List.product (states_as_list M1) (states_as_list M1))));
      distHelper = (\<lambda> q1 q2 . if q1 \<in> states M1 \<and> q2 \<in> states M1 \<and> q1 \<noteq> q2 then the (Mapping.lookup distMap (q1,q2)) else get_distinguishing_sequence_from_ofsm_tables M1 q1 q2)
    in
      spy_framework M1
                     get_state_cover_assignment
                     (handle_state_cover_dynamic completeInputTraces useInputHeuristic distHelper)
                     sort_unverified_transitions_by_state_cover_length
                     (establish_convergence_dynamic completeInputTraces useInputHeuristic distHelper)
                     (handle_io_pair completeInputTraces useInputHeuristic)
                     simple_cg_initial
                     simple_cg_insert
                     simple_cg_lookup_with_conv
                     simple_cg_merge
                     m)"
  unfolding spyh_method_via_spy_framework_def
  apply (subst (1 2) get_distinguishing_sequence_from_ofsm_tables_precomputed[of M1])
  unfolding Let_def
  by presburger

end