theory Numerical_Example
imports
  Environment_Executable
  Test_Code_Generation_Real_Approx
  Overtaking_rules
begin

text \<open>The lane consists of two lanelets with the same direction. All lane boundaries are
  simply straight lanes.\<close>

definition bound0 :: "(real2 \<times> real2) list" where "bound0 = [((-35,-2.25),(200,-2.251))]"
definition bound1 :: "(real2 \<times> real2) list" where "bound1 = [((-35, 2.25),(200, 2.251))]"
definition bound2 :: "(real2 \<times> real2) list" where "bound2 = [((-35, 6.75),(200, 6.751))]"

text \<open>Interpreting the definition @{term "lane2'"} locale\<close>

global_interpretation l2': lane2' bound0 bound1 bound2
  defines lane_detection = l2'.Lane.lane_detection and
  in_lane = l2'.in_lane2  and
  in_lane' = l2'.Lane.in_lane and
  lines_inside0 = l2'.lane0.lines_inside and
  lines_inside1 = l2'.lane1.lines_inside and
  intersect_boundaries0 = l2'.lane0.intersect_boundaries and
  intersect_boundaries1 = l2'.lane1.intersect_boundaries and
  intersect_right_boundary0 = l2'.lane0.intersect_right_boundary and
  intersect_right_boundary1 = l2'.lane1.intersect_right_boundary and
  intersect_left_boundary0 = l2'.lane0.intersect_left_boundary and
  intersect_left_boundary1 = l2'.lane1.intersect_left_boundary and
  rectangle_inside0 = l2'.lane0.rectangle_inside and
  rectangle_inside1 = l2'.lane1.rectangle_inside and
  lane_boundaries_touched = l2'.Lane.lane_boundaries_touched and
  point_in_drivable_area0 = l2'.lane0.point_in_drivable_area and
  point_in_drivable_area1 = l2'.lane1.point_in_drivable_area and
  direction_right0 = l2'.lane0.direction_right and
  direction_right1 = l2'.lane1.direction_right and
  rectangle_intersect0 = l2'.bound0.rectangle_intersect and
  rectangle_intersect1 = l2'.bound1.rectangle_intersect and
  rectangle_intersect2 = l2'.bound2.rectangle_intersect and
  vertices_inside0 = l2'.lane0.vertices_inside and
  lane_boundaries_touched2 = l2'.lane_boundaries_touched2 and
  vertices_inside1 = l2'.lane1.vertices_inside and
  initial_lane = l2'.Lane.initial_lane and
  start_inc_lane = l2'.Lane.start_inc_lane and
  finish_inc_lane = l2'.Lane.finish_inc_lane and
  increase_lane = l2'.Lane.increase_lane and
  decrease_lane = l2'.Lane.decrease_lane and
  start_dec_lane = l2'.Lane.start_dec_lane and
  finish_dec_lane = l2'.Lane.finish_dec_lane and
  overtaking = l2'.Lane.overtaking and
  overtaking_trace = l2'.Lane.overtaking_trace and
  fast_lane_trace = l2'.Lane.fast_lane_trace and
  merging_trace = l2'.Lane.merging_trace and
  original_lane_trace = l2'.Lane.original_lane_trace and
  time_points_to_ov_bools = l2'.Lane.time_points_to_ov_bools and
  time_points_to_fl_bools = l2'.Lane.time_points_to_fl_bools and
  time_points_to_merge_bools = l2'.Lane.time_points_to_merge_bools and
  time_points_to_ori_bools = l2'.Lane.time_points_to_ori_bools and
  overtaking_checker = l2'.Lane.overtaking_checker and
  onfastlane_checker = l2'.Lane.onfastlane_checker and
  merging_checker = l2'.Lane.merging_checker and
  original_lane_checker = l2'.Lane.original_lane_checker and
  sd_rear_checker = l2'.Lane.sd_rear_checker and
  sd_rear_checker' = l2'.Lane.sd_rear_checker' and
  sd_rears = l2'.Lane.sd_rears and
  sd_rear = l2'.Lane.sd_rear and
  sd_rear' = l2'.Lane.sd_rear' and
  sd_raw_state = l2'.Lane.sd_raw_state and
  vehicles_behind = l2'.Lane.vehicles_behind and
  trim_vehicles_same_lane = l2'.Lane.trim_vehicles_same_lane and
  safe_to_return_trace = l2'.Lane.safe_to_return_trace and
  safe_to_return_checker = l2'.Lane.safe_to_return_checker and
  closest_vehicles_infront_idx = l2'.Lane.closest_vehicles_infront_idx and
  vehicles_infront = l2'.Lane.vehicles_infront and
  sd_raw_state_list' = l2'.Lane.sd_raw_state_list' and
  sd_raw_state_list = l2'.Lane.sd_raw_state_list
  by (unfold_locales) (eval+)

lemma [code]: "finish_dec_lane uu i num =
  (case i of
    0 \<Rightarrow> None
  | Suc v \<Rightarrow>
    case uu of
      [] \<Rightarrow> None
   | (rect # rects) \<Rightarrow>
  (case lane_detection rect of Outside \<Rightarrow> None
   | Lane n \<Rightarrow> if n = Suc v - 1 then Some (num, rects) else None
   | Boundaries ns \<Rightarrow>
       if tl ns = [] \<and> hd ns = Suc v
       then finish_dec_lane rects (Suc v) (num + 1) else None))"
  by (auto split: nat.splits list.splits)

text \<open>Preparing the trace\<close>

definition xpos :: "real list" where
"xpos =
[
         0,    1.6657,    3.3299,    4.9924,    6.6525,    8.3097,    9.9629,   11.6121,   13.2576,   14.8995,   16.5373,   18.1708,   19.7999,   21.4245,   23.0449,   24.6612,
   26.2739,   27.8833,   29.4899,   31.0942,   32.6956,   34.2943,   35.8899,   37.4826,   39.0721,   40.6585,   42.2417,   43.8217,   45.3985,   46.9722,   48.5428,   50.1104,
   51.6749,   53.2366,   54.7955,   56.3516,   57.9051,   59.4560,   61.0044,   62.5505,   64.0943,   65.6359,   67.1755,   68.7131,   70.2490,   71.7831,   73.3156,   74.8467,
   76.3764,   77.9050,   79.4326,   80.9593,   82.4852,   84.0106,   85.5356,   87.0603,   88.5850,   90.1098,   91.6349,   93.1606,   94.6869,   96.2141,   97.7425,   99.2722,
  100.8035,  102.3365,  103.8716,  105.4097,  106.9516,  108.4977,  110.0486,  111.6043,  113.1649,  114.7304,  116.3007,  117.8756,  119.4551,  121.0392,  122.6280,  124.2215,
  125.8199,  127.4233,  129.0319,  130.6458,  132.2650,  133.8893,  135.5186,  137.1525,  138.7910,  140.4335,  142.0797,  143.7293,  145.3821,  147.0375,  148.6949,  150.3541,
  152.0148,  153.6768,  155.3399,  157.0040,  158.6687
]"

definition ypos :: "real list" where
"ypos =
[
   -0.0005,    0.0185,    0.0712,    0.1619,    0.2923,    0.4609,    0.6655,    0.9007,    1.1607,    1.4384,    1.7260,    2.0161,    2.3057,    2.5874,    2.8549,    3.1037,
    3.3271,    3.5250,    3.6917,    3.8293,    3.9450,    4.0410,    4.1199,    4.1843,    4.2365,    4.2785,    4.3123,    4.3393,    4.3608,    4.3780,    4.3916,    4.4023,
    4.4109,    4.4177,    4.4230,    4.4272,    4.4306,    4.4332,    4.4353,    4.4369,    4.4382,    4.4392,    4.4400,    4.4406,    4.4411,    4.4415,    4.4418,    4.4420,
    4.4422,    4.4424,    4.4425,    4.4425,    4.4426,    4.4426,    4.4427,    4.4427,    4.4427,    4.4427,    4.4427,    4.4427,    4.4427,    4.4427,    4.4427,    4.4427,
    4.4427,    4.4426,    4.4256,    4.3786,    4.2998,    4.1888,    4.0469,    3.8764,    3.6807,    3.4639,    3.2304,    2.9854,    2.7336,    2.4800,    2.2291,    1.9851,
    1.7516,    1.5314,    1.3270,    1.1397,    0.9706,    0.8200,    0.6875,    0.5725,    0.4738,    0.3901,    0.3198,    0.2614,    0.2132,    0.1738,    0.1416,    0.1154,
    0.0942,    0.0769,    0.0629,    0.0513,    0.0419
]"

definition oris :: "real list" where
"oris =
[
         0,    0.0102,    0.0244,    0.0425,    0.0625,    0.0830,    0.1036,    0.1220,    0.1383,    0.1511,    0.1603,    0.1656,    0.1689,    0.1678,    0.1633,    0.1557,
    0.1442,    0.1313,    0.1154,    0.1010,    0.0872,    0.0743,    0.0627,    0.0525,    0.0436,    0.0360,    0.0295,    0.0241,    0.0196,    0.0159,    0.0129,    0.0104,
    0.0083,    0.0067,    0.0053,    0.0043,    0.0034,    0.0027,    0.0022,    0.0017,    0.0014,    0.0011,    0.0009,    0.0007,    0.0005,    0.0004,    0.0003,    0.0003,
    0.0002,    0.0002,    0.0001,    0.0001,    0.0001,    0.0001,    0.0001,    0.0000,    0.0000,    0.0000,    0.0000,    0.0000,    0.0000,    0.0000,    0.0000,    0.0000,
    0.0000,    0.0000,   -0.0099,   -0.0235,   -0.0397,   -0.0572,   -0.0749,   -0.0920,   -0.1078,   -0.1217,   -0.1332,   -0.1421,   -0.1483,   -0.1516,   -0.1522,   -0.1502,
   -0.1459,   -0.1397,   -0.1318,   -0.1226,   -0.1125,   -0.1020,   -0.0913,   -0.0807,   -0.0706,   -0.0611,   -0.0523,   -0.0444,   -0.0373,   -0.0312,   -0.0259,   -0.0214,
   -0.0176,   -0.0145,   -0.0119,   -0.0098,   -0.0081
]"

definition lengths :: "real list" where
  "lengths = replicate 101 4.8"

definition widths :: "real list" where
  "widths = replicate 101 2"

definition veloxs :: "real list" where
"veloxs =
[
   16.6667,   16.6596,   16.6519,   16.6401,   16.6242,   16.6017,   16.5709,   16.5368,   16.5027,   16.4650,   16.4239,   16.3803,   16.3360,   16.2915,   16.2484,   16.2078,
   16.1709,   16.1375,   16.1085,   16.0809,   16.0528,   16.0239,   15.9940,   15.9632,   15.9316,   15.8995,   15.8671,   15.8347,   15.8024,   15.7704,   15.7388,   15.7078,
   15.6774,   15.6477,   15.6187,   15.5906,   15.5632,   15.5367,   15.5112,   15.4866,   15.4629,   15.4403,   15.4188,   15.3983,   15.3790,   15.3608,   15.3439,   15.3282,
   15.3138,   15.3008,   15.2891,   15.2789,   15.2702,   15.2630,   15.2575,   15.2535,   15.2513,   15.2509,   15.2523,   15.2555,   15.2607,   15.2679,   15.2772,   15.2885,
   15.3021,   15.3179,   15.3382,   15.3655,   15.3995,   15.4391,   15.4825,   15.5282,   15.5746,   15.6209,   15.6664,   15.7111,   15.7553,   15.7998,   15.8450,   15.8911,
   15.9386,   15.9879,   16.0389,   16.0911,   16.1433,   16.1951,   16.2455,   16.2940,   16.3402,   16.3829,   16.4226,   16.4594,   16.4932,   16.5215,   16.5460,   16.5672,
   16.5856,   16.6016,   16.6152,   16.6264,   16.6352
]"

definition veloys :: "real list" where
"veloys =
[
         0,    0.1692,    0.4065,    0.7073,    1.0404,    1.3816,    1.7223,    2.0276,    2.2965,    2.5071,    2.6553,    2.7370,    2.7850,    2.7597,    2.6766,    2.5442,
    2.3487,    2.1312,    1.8666,    1.6294,    1.4026,    1.1932,    1.0049,    0.8390,    0.6954,    0.5726,    0.4690,    0.3822,    0.3103,    0.2509,    0.2023,    0.1627,
    0.1305,    0.1045,    0.0835,    0.0667,    0.0531,    0.0423,    0.0337,    0.0268,    0.0213,    0.0169,    0.0134,    0.0106,    0.0084,    0.0067,    0.0053,    0.0042,
    0.0033,    0.0026,    0.0021,    0.0017,    0.0013,    0.0010,    0.0008,    0.0007,    0.0005,    0.0004,    0.0003,    0.0003,    0.0002,    0.0002,    0.0001,    0.0001,
    0.0001,    0.0001,   -0.1513,   -0.3615,   -0.6114,   -0.8834,   -1.1619,   -1.4332,   -1.6858,   -1.9103,   -2.0994,   -2.2480,   -2.3530,   -2.4134,   -2.4300,   -2.4051,
   -2.3427,   -2.2476,   -2.1255,   -1.9823,   -1.8242,   -1.6573,   -1.4870,   -1.3183,   -1.1554,   -1.0018,   -0.8597,   -0.7309,   -0.6162,   -0.5156,   -0.4288,   -0.3549,
   -0.2927,   -0.2409,   -0.1981,   -0.1630,   -0.1343
]"

definition velos :: "real2 list" where
  "velos = zip veloxs veloys"

definition max_decelxs :: "real list" where
"max_decelxs =
[
   -8.0000,   -7.9996,   -7.9976,   -7.9928,   -7.9844,   -7.9724,   -7.9571,   -7.9405,   -7.9236,   -7.9088,   -7.8975,   -7.8906,   -7.8862,   -7.8876,   -7.8936,   -7.9032,
   -7.9169,   -7.9311,   -7.9468,   -7.9592,   -7.9696,   -7.9779,   -7.9843,   -7.9890,   -7.9924,   -7.9948,   -7.9965,   -7.9977,   -7.9985,   -7.9990,   -7.9993,   -7.9996,
   -7.9997,   -7.9998,   -7.9999,   -7.9999,   -8.0000,   -8.0000,   -8.0000,   -8.0000,   -8.0000,   -8.0000,   -8.0000,   -8.0000,   -8.0000,   -8.0000,   -8.0000,   -8.0000,
   -8.0000,   -8.0000,   -8.0000,   -8.0000,   -8.0000,   -8.0000,   -8.0000,   -8.0000,   -8.0000,   -8.0000,   -8.0000,   -8.0000,   -8.0000,   -8.0000,   -8.0000,   -8.0000,
   -8.0000,   -8.0000,   -7.9996,   -7.9978,   -7.9937,   -7.9869,   -7.9776,   -7.9661,   -7.9535,   -7.9408,   -7.9291,   -7.9193,   -7.9122,   -7.9083,   -7.9076,   -7.9099,
   -7.9150,   -7.9221,   -7.9307,   -7.9400,   -7.9494,   -7.9584,   -7.9667,   -7.9739,   -7.9801,   -7.9851,   -7.9891,   -7.9921,   -7.9944,   -7.9961,   -7.9973,   -7.9982,
   -7.9988,   -7.9992,   -7.9994,   -7.9996,   -7.9997
]"

definition max_decelys :: "real list" where
"max_decelys =
[
         0,   -0.0812,   -0.1952,   -0.3397,   -0.4997,   -0.6635,   -0.8270,   -0.9736,   -1.1026,   -1.2043,   -1.2768,   -1.3184,   -1.3445,   -1.3361,   -1.3003,   -1.2406,
   -1.1499,   -1.0474,   -0.9209,   -0.8065,   -0.6963,   -0.5941,   -0.5016,   -0.4199,   -0.3488,   -0.2879,   -0.2363,   -0.1931,   -0.1570,   -0.1273,   -0.1028,   -0.0829,
   -0.0666,   -0.0534,   -0.0428,   -0.0342,   -0.0273,   -0.0218,   -0.0174,   -0.0138,   -0.0110,   -0.0087,   -0.0070,   -0.0055,   -0.0044,   -0.0035,   -0.0028,   -0.0022,
   -0.0017,   -0.0014,   -0.0011,   -0.0009,   -0.0007,   -0.0005,   -0.0004,   -0.0003,   -0.0003,   -0.0002,   -0.0002,   -0.0001,   -0.0001,   -0.0001,   -0.0001,   -0.0000,
   -0.0000,   -0.0000,    0.0789,    0.1882,    0.3174,    0.4570,    0.5987,    0.7353,    0.8609,    0.9711,    1.0626,    1.1331,    1.1817,    1.2080,    1.2127,    1.1972,
    1.1634,    1.1137,    1.0510,    0.9782,    0.8983,    0.8144,    0.7292,    0.6451,    0.5643,    0.4883,    0.4182,    0.3549,    0.2987,    0.2496,    0.2073,    0.1713,
    0.1411,    0.1161,    0.0954,    0.0784,    0.0646
]"

definition max_decels :: "real2 list" where
  "max_decels = zip max_decelxs max_decelys"

fun mk_rectangles :: "real list \<Rightarrow> real list \<Rightarrow> real list \<Rightarrow> real list \<Rightarrow> real list \<Rightarrow> rectangle list" where
  "mk_rectangles    []       []      []        []       []    = []" |
  "mk_rectangles (x # xs) (y # ys) (p # ps) (l # ls) (w # ws) = \<lparr>Xcoord = x, Ycoord = y, Orient = p, Length = l, Width = w\<rparr> # mk_rectangles xs ys ps ls ws"

definition rectangles where "rectangles = mk_rectangles xpos ypos oris lengths widths"

definition "test" where "test \<equiv> \<lambda>rect. start_inc_lane rect 0 0"

declare [[ML_print_depth=1000]]

ML\<open>
val rectangles = @{code rectangles};
val test_rectangle = nth rectangles 13;
val test_rectangle2 = nth rectangles 84;
val get_vertices = @{code get_vertices_zero};
val tr_gv = get_vertices test_rectangle2;
val transpose = @{code List.transpose};
val test_rectangle3 = nth rectangles 8;
val get_vertices_rot = @{code get_vertices_rotated_translated};
val rotated3 =  get_vertices_rot test_rectangle3;
val in_lane = @{code in_lane};
val test_in_lane = in_lane test_rectangle
val rectangle_intersect1 = @{code rectangle_intersect1};
val test_intersect1 = rectangle_intersect1 test_rectangle;
val get_lines = @{code get_lines};
val test_get_lines = get_lines test_rectangle;
val first_line = nth test_get_lines 0;
val rectangle_inside1 = @{code rectangle_inside1};
val test_rectin1 = map rectangle_inside1 rectangles;
val vertices_inside1 = @{code vertices_inside1};
val test_inside1 = map vertices_inside1 rectangles;
val lane_detection = @{code lane_detection};
val test_lane_detection = map lane_detection rectangles;
val start_inc_lane = @{code test};
val test_start_inc_lane = start_inc_lane rectangles ;
val increase_lane = @{code increase_lane};
val test_overtaking = increase_lane rectangles;
val decrease_lane = @{code decrease_lane}
val overtaking = @{code overtaking}
val test_overtaking = overtaking rectangles;
val overtaking_trace = @{code overtaking_trace};
val test_overtaking_trace = overtaking_trace rectangles;
val fast_lane_trace = @{code fast_lane_trace}
val test_fast_lane_trace = fast_lane_trace rectangles;
val merging_trace = @{code merging_trace}
val test_merging_trace = merging_trace rectangles;
val original_lane_trace = @{code original_lane_trace};
val test_original_lane_trace = original_lane_trace rectangles;
\<close>

fun mk_raw_state :: "real list \<Rightarrow> real list \<Rightarrow> real list \<Rightarrow> real list \<Rightarrow> real list \<Rightarrow> real2 list \<Rightarrow> real2 list \<Rightarrow> raw_state list" where
  "mk_raw_state    []       []      []        []       []       []       []    = []" |
  "mk_raw_state (x # xs) (y # ys) (p # ps) (l # ls) (w # ws) (v # vs) (a # as) = \<lparr>Xcoord = x, Ycoord = y, Orient = p, Length = l, Width = w, velocity = v, acceleration = a\<rparr> # mk_raw_state xs ys ps ls ws vs as"

definition raw_states where "raw_states = mk_raw_state xpos ypos oris lengths widths velos max_decels"
definition ego_run where "ego_run = (Motorised, raw_states)"

text \<open>Trace for vehicle being overtaken. The length of the trace is equivalent to that of
ego vehicle.\<close>

lemma "length veloxs = 101" unfolding veloxs_def by auto

text \<open>The other vehicle is positioned at @{term "(19,0)"} initially. The rest is calculated by
simply using @{term "s + v * t"}. Each time point is @{term "0.1"} s.\<close>

definition xpos_one :: "real list" where
  "xpos_one = 19 # [19 + 11.1 * 0.1 * t . t \<leftarrow> [1..100]]"

definition ypos_one :: "real list" where
  "ypos_one = replicate 101 0"

definition oris_one :: "real list" where
  "oris_one = replicate 101 0"

definition rectangles_other_one where "rectangles_other_one \<equiv> mk_rectangles xpos_one ypos_one oris_one lengths widths"

text \<open>The vehicle being overtaken is assumed to maintain its current speed. It is not allowed
to accelerate when the vehicle is being overtaken.\<close>

definition veloxs_one :: "real list" where
  "veloxs_one = replicate 101 11.1"

definition veloys_one :: "real list" where
  "veloys_one = replicate 101 0"

definition velos_one :: "real2 list" where
  "velos_one = zip veloxs_one veloys_one"

definition reaction_time :: "real" where
  "reaction_time = 0.5"

definition raw_states_other where "raw_states_other = mk_raw_state xpos_one ypos_one oris_one lengths widths velos_one max_decels"
definition other_one_run where "other_one_run = (Motorised, raw_states_other)"

text \<open>Trace for the second vehicle.\<close>

definition xpos_two :: "real list" where
  "xpos_two = -25 # [-25 + 16.7 * 0.1 * t. t \<leftarrow> [1..100]]"

lemma "length xpos_two = 101" unfolding xpos_two_def by eval

definition ypos_two :: "real list" where
  "ypos_two = replicate 101 4.5"

definition oris_two :: "real list" where
  "oris_two = replicate 101 0"

definition rectangles_other_two where "rectangles_other_two \<equiv> mk_rectangles xpos_two ypos_two oris_two lengths widths"

definition veloxs_two :: "real list" where
  "veloxs_two = replicate 101 16.7"

definition veloys_two :: "real list" where
  "veloys_two = replicate 101 0"

definition velos_two :: "real2 list" where
  "velos_two = zip veloxs_two veloys_two"

definition raw_states_other_two where "raw_states_other_two \<equiv> mk_raw_state xpos_two ypos_two oris_two lengths widths velos_two max_decels"
definition other_two_run where "other_two_run \<equiv> (Motorised, raw_states_other_two)"
definition black_boxes :: black_boxes where "black_boxes = (ego_run, [other_one_run, other_two_run])"

definition toc where "toc \<equiv> overtaking_checker black_boxes"
definition tfl where "tfl \<equiv> onfastlane_checker black_boxes"
definition tm where "tm \<equiv> merging_checker black_boxes"
definition tol where "tol \<equiv> original_lane_checker black_boxes"
definition tsd where "tsd \<equiv> sd_rear_checker black_boxes reaction_time"
definition tsr where "tsr \<equiv> safe_to_return_checker black_boxes reaction_time"

value [code] "toc"
value [code] "tfl"
value [code] "tm"
value [code] "tol"
value [code] "tsd"
value [code] "List.enumerate 0 (zip tol tsd)"

definition eight_list where "eight_list \<equiv> nth_list 73 (map snd (snd black_boxes))"

ML \<open>
val test = @{code sd_rear_checker'} @{code black_boxes} @{code reaction_time};
val other_runs_t = @{code List.transpose} (map snd (snd @{code black_boxes}));
val ego_run = snd (fst @{code black_boxes});
val test = @{code sd_rears} other_runs_t ego_run @{code reaction_time};
val eight_list = @{code eight_list};
val eight_ego = List.nth (ego_run, 73);
val test2 = @{code sd_rear} eight_list eight_ego @{code reaction_time};
val veh_behind = @{code vehicles_behind} eight_list eight_ego;
val sd_rear_prime = @{code sd_rear'} veh_behind eight_ego @{code reaction_time};
(* val sd_raw_state = @{code sd_raw_state} (hd veh_behind) eight_ego @{code reaction_time};
 *)
\<close>

value [code] "tsr"

definition temp where "temp or so \<equiv>  [f or. f \<leftarrow> (map nth_list so)]"
definition temp2 where "temp2 bb so \<equiv> [f (snd (fst bb)) . f \<leftarrow> (map (\<lambda>n xs. xs ! n) so)]"
definition temp3 where "temp3 or ovp \<equiv> [f or. f \<leftarrow> (map (\<lambda>n xss. xss !n) ovp)]"
ML \<open>
val ego_rects = @{code bb_to_rects} @{code black_boxes};
val ov_nums = @{code overtaking} ego_rects;
val start_ovs = map fst ov_nums;
val other_runs = map snd (snd @{code black_boxes});
val choppeds = @{code temp} other_runs start_ovs;
val ego_chopped = @{code temp2} @{code black_boxes} start_ovs;
val overtaken_vehs = map ((fn f => fn p => f (fst p) (snd p)) @{code closest_vehicles_infront_idx})
                                                              (@{code zip} (@{code List.transpose} choppeds) ego_chopped);
val overtaken_vehs' = @{code take_some} overtaken_vehs;
val relevant_trace = @{code temp3} other_runs overtaken_vehs';
val result = @{code sd_raw_state_list} relevant_trace (snd (fst @{code black_boxes})) @{code reaction_time}
val result2 = @{code List.enumerate} @{code "0 :: nat"} (@{code nth} result @{code "0 :: nat"});
List.nth(snd (fst @{code black_boxes}), 36);
List.nth(List.nth (relevant_trace, 0), 36);
\<close>

fun combine_to_trace :: "tr_atom set list list \<Rightarrow> tr_atom set list \<Rightarrow> tr_atom set list" where
  "combine_to_trace [] res = res" |
  "combine_to_trace (x # xs) res = combine_to_trace xs (map (\<lambda>x. union (fst x) (snd x)) (zip x res))"

definition empty_trace :: "tr_atom set list" where "empty_trace \<equiv> replicate 101 {}"
definition complete_trace where "complete_trace \<equiv> combine_to_trace [toc, tfl, tm, tol, tsd, tsr] empty_trace"

definition semantics_ltlf_tr :: "tr_atom set list \<Rightarrow> tr_atom ltlf \<Rightarrow> bool" where
  "semantics_ltlf_tr \<equiv> semantics_ltlf"

ML \<open>
val monitor = @{code monitor_tr};
val monitor2 = @{code semantics_ltlf_tr};
val comp_trace = @{code complete_trace};
val phi1 = @{code \<Phi>1}
val test_phi1 = monitor comp_trace phi1;
val test_phi1' = monitor2 comp_trace phi1;
val phi3_weaker = @{code \<Phi>3_weaker};
val test_phi3_weaker = monitor comp_trace phi3_weaker;
val test_phi3'_weaker = monitor2 comp_trace phi3_weaker;
val phi3 = @{code \<Phi>3};
val test_phi3 = monitor comp_trace phi3;
val phi4 = @{code \<Phi>4};
val test_phi4 = monitor2 comp_trace phi4;
\<close>


theory LaunchburyCombined
imports Terms Heap "FMap-Heap" "FMap-Nominal" Flag
begin

lemma fdom_fmap_of_conv_heapVars: "fdom (fmap_of (asToHeap as)) = heapVars (asToHeap as)"
  by (metis dom_map_of_conv_heapVars fdom.rep_eq fmap_of.rep_eq)

lemma set_bn_to_atom_fdom: "set (bn as) = atom ` fdom (fmap_of (asToHeap as))"
  by (metis fdom_fmap_of_conv_heapVars set_bn_to_atom_heapVars)

lemma fresh_at_base_list: "atom (x::'a::at_base) \<sharp> l \<longleftrightarrow> x \<notin> set l"
  by (metis List.finite_set fresh_finite_set_at_base fresh_set)

lemma fresh_star_list_distinct:  "atom ` (S::var set) \<sharp>* (l::var list) \<longleftrightarrow> (set l \<inter> S = {})"
  by (auto simp add: fresh_star_def set_not_fresh fresh_at_base_list dest:bspec)

subsubsection {* The natural semantics, all variants at once*}

inductive
  reds :: "Heap \<Rightarrow> exp \<Rightarrow> Flag \<Rightarrow> Flag \<Rightarrow> var list \<Rightarrow> Heap \<Rightarrow> exp \<Rightarrow> bool"
  ("(4_ : _/ \<Down>\<^sup>_\<^sup>_\<^bsub>_\<^esub>/ _ : _)" [50,50,50,50,50,50] 50)
where
  Lambda: "atom x \<sharp> (\<Gamma>, L)
    \<Longrightarrow> \<Gamma> : Lam [x]. e \<Down>\<^sup>i\<^sup>b\<^bsub>L\<^esub> \<Gamma> : Lam [x]. e"
 | Application: "\<lbrakk>
    atom y \<sharp> (\<Gamma>,e,x,L,\<Delta>,\<Theta>,z) ;
    \<Gamma> : e \<Down>\<^sup>\<times>\<^sup>b\<^bsub>x#L\<^esub> \<Delta> : (Lam [y]. e');
    \<Delta> : e'[y ::= x] \<Down>\<^sup>\<times>\<^sup>b\<^bsub>L\<^esub> \<Theta> : z
  \<rbrakk>  \<Longrightarrow>
    \<Gamma> : App e x \<Down>\<^sup>\<times>\<^sup>b\<^bsub>L\<^esub> \<Theta> : z"
 | ApplicationInd: "\<lbrakk>
    atom y \<sharp> (\<Gamma>,e,x,L);
    \<Gamma> : e \<Down>\<^sup>\<surd>\<^sup>u\<^bsub>y#x#L\<^esub> \<Delta> : (Lam [y]. e');
    \<Delta>(y f\<mapsto> Var x) : e' \<Down>\<^sup>\<surd>\<^sup>u \<^bsub>L\<^esub> \<Theta> : z
  \<rbrakk>  \<Longrightarrow>
    \<Gamma> : App e x \<Down>\<^sup>\<surd>\<^sup>u\<^bsub>L\<^esub> \<Theta> : z"
 | Variable: "\<lbrakk>
    lookup \<Gamma> x = Some e; fmap_delete x \<Gamma> : e \<Down>\<^sup>i\<^sup>\<surd>\<^bsub>x#L\<^esub> \<Delta> : z
  \<rbrakk> \<Longrightarrow>
    \<Gamma> : Var x \<Down>\<^sup>i\<^sup>\<surd>\<^bsub>L\<^esub> \<Delta>(x f\<mapsto> z) : z"
 | VariableNoBH: "\<lbrakk>
    lookup \<Gamma> x = Some e;  \<Gamma> : e \<Down>\<^sup>i\<^sup>\<times>\<^bsub>x#L\<^esub> \<Delta> : z
  \<rbrakk> \<Longrightarrow>
    \<Gamma> : Var x \<Down>\<^sup>i\<^sup>\<times>\<^bsub>L\<^esub> \<Delta>(x f\<mapsto> z) : z"
 | Let: "\<lbrakk>
    set (bn as) \<sharp>* (\<Gamma>, L);
    \<Gamma> f++ (fmap_of (asToHeap as)) : body \<Down>\<^sup>i\<^sup>u\<^bsub>L\<^esub> \<Delta> : z
  \<rbrakk> \<Longrightarrow>
    \<Gamma> : Let as body \<Down>\<^sup>i\<^sup>u\<^bsub>L\<^esub> \<Delta> : z"

equivariance reds

nominal_inductive reds
avoids Lambda: "x" | Application: "y"
apply (auto simp add: fresh_star_def fresh_Pair pure_fresh)
done

lemma LambdaI: "\<Gamma> : Lam [x]. e \<Down>\<^sup>i\<^sup>u\<^bsub>L\<^esub> \<Gamma> : Lam [x]. e"
proof-
  obtain x' :: var where "atom x' \<sharp> (\<Gamma>, L, e)"  by (rule obtain_fresh)
  hence "atom x' \<sharp> (\<Gamma>, L)" and [simp]:"atom x' \<sharp> e" by (simp_all add: fresh_Pair)

  have "(x \<leftrightarrow> x') \<bullet> Lam [x]. e = Lam [x]. e"
    by (rule flip_fresh_fresh) simp+
  moreover
  have "(x \<leftrightarrow> x') \<bullet> Lam [x]. e = Lam [x']. ((x \<leftrightarrow> x') \<bullet> e)" by simp
  moreover
  from `atom x' \<sharp> (\<Gamma>, L)`
  have "\<Gamma> : Lam [x']. ((x \<leftrightarrow> x') \<bullet> e) \<Down>\<^sup>i\<^sup>u\<^bsub>L\<^esub> \<Gamma> : Lam [x']. ((x \<leftrightarrow> x') \<bullet> e)"
    by (rule Lambda)
  ultimately
  show ?thesis by metis
qed

subsubsection {* Specializations*}

abbreviation
  reds_NS :: "Heap \<Rightarrow> exp \<Rightarrow> var list \<Rightarrow> Heap \<Rightarrow> exp \<Rightarrow> bool" ("_ : _ \<Down>\<^bsub>_\<^esub> _ : _" [50,50,50,50] 50)
where
  "\<Gamma> : e \<Down>\<^bsub>L\<^esub> \<Delta> : z \<equiv> \<Gamma> : e \<Down>\<^sup>\<times>\<^sup>\<surd>\<^bsub>L\<^esub> \<Delta> : z"

lemma eval_test_NS:
  "f\<emptyset> : (Let (ACons x (Lam [y]. Var y) ANil) (Var x)) \<Down>\<^bsub>[]\<^esub> f\<emptyset>(x f\<mapsto> Lam [y]. Var y) : (Lam [y]. Var y)"
  by (auto intro!: LambdaI Variable Let simp add: fresh_Pair fresh_Cons fresh_Nil fresh_star_def)

lemma eval_test2_NS:
  "y \<noteq> x \<Longrightarrow> n \<noteq> y \<Longrightarrow> n \<noteq> x \<Longrightarrow>
  f\<emptyset> : (Let (ACons x (Lam [y]. Var y) ANil) (App (Var x) x)) \<Down>\<^bsub>[]\<^esub> f\<emptyset>(x f\<mapsto> Lam [y]. Var y) : Lam [y]. Var y"
  by (auto intro!: LambdaI Application Variable Let simp add: fresh_Pair fresh_at_base fresh_Cons fresh_Nil fresh_star_def pure_fresh fresh_fmap_upd_eq)

text {* This lemma shows that variables not free in the initial expression can still become
new names on the heap. *}
lemma eval_test3_NS:
  "y \<noteq> x \<Longrightarrow> f\<emptyset> : (App (Lam [y]. let x be Var x in (Lam [z].Var z))) x \<Down>\<^bsub>[]\<^esub> f\<emptyset>(x f\<mapsto> Var x) : Lam [z]. Var z"
apply (rule Application[where y = y, rotated])
  apply (rule LambdaI)
 apply (simp add: subst_fresh_noop fresh_at_base)
 apply (rule Let)
   apply (simp add: fresh_star_Pair fresh_star_def fresh_Nil)
  apply simp
 apply (rule LambdaI)
 apply (simp add: fresh_Pair fresh_Nil fresh_Cons fresh_at_base fresh_fmap_upd_eq)
done

subsubsection {* Properties of the semantics *}

text {*
Heap entries are never removed.
*}

lemma reds_doesnt_forget:
  "\<Gamma> : e \<Down>\<^sup>i\<^sup>b\<^bsub>L\<^esub> \<Delta> : z \<Longrightarrow> fdom \<Gamma> \<subseteq> fdom \<Delta>"
  by(induct rule: reds.induct) auto

text {*
Live variables are not added to the heap.
*}

lemma reds_avoids_live:
  "\<lbrakk> \<Gamma> : e \<Down>\<^sup>i\<^sup>b\<^bsub>L\<^esub> \<Delta> : z;
   x \<in> set L;
   x \<notin> fdom \<Gamma>
  \<rbrakk> \<Longrightarrow> x \<notin> fdom \<Delta>"
proof(induction rule:reds.induct)
case (Lambda \<Gamma> x e L) thus ?case by auto
next
case (Application y \<Gamma> e x' L \<Delta> z \<Theta> u e')
  thus ?case by (auto simp add: fresh_Pair dest: fresh_list_elem)
next
case (ApplicationInd y \<Gamma> e x' L \<Delta> z u e' \<Theta>)
  thus ?case by (auto simp add: fresh_Pair dest: fresh_list_elem)
next
case (Variable  x e \<Gamma> L \<Delta> z) thus ?case by auto
next
case (VariableNoBH  x e \<Gamma> L \<Delta> z) thus ?case by auto
next
case (Let as \<Gamma> L body \<Delta> z)
  have "x \<notin> fdom \<Gamma>" by fact moreover
  have "set (bn as) \<sharp>* L" using `set (bn as) \<sharp>* (\<Gamma>, L)` by (simp add: fresh_star_Pair)
  hence "x \<notin> fdom (fmap_of (asToHeap as))"
    using `x \<in> set L`
    apply (auto simp add: fdom_fmap_of_conv_heapVars set_bn_to_atom_fdom)
    by (metis disjoint_iff_not_equal fresh_star_list_distinct)
  ultimately
  have"x \<notin> fdom (\<Gamma> f++ fmap_of (asToHeap as))" by auto
  thus ?case
    by (rule Let.IH[OF `x \<in> set L`])
qed

text {*
Fresh variables either stay fresh or are added to the heap.
*}

lemma reds_fresh:" \<lbrakk> \<Gamma> : e \<Down>\<^sup>i\<^sup>b\<^bsub>L\<^esub> \<Delta> : z;
   atom (x::var) \<sharp> (\<Gamma>, e)
  \<rbrakk> \<Longrightarrow> atom x \<sharp> (\<Delta>, z) \<or> x \<in> (fdom \<Delta> - set L)"
proof(induction rule: reds.induct)
case (Lambda \<Gamma> x e) thus ?case by auto
next
case (Application y \<Gamma> e x' L \<Delta> \<Theta> z u e')
  hence "atom x \<sharp> (\<Delta>, Lam [y]. e') \<or> x \<in> fdom \<Delta> - set (x' # L)" by (auto simp add: fresh_Pair)

  thus ?case
  proof
    assume  "atom x \<sharp> (\<Delta>, Lam [y]. e')"
    moreover
    have "atom x \<sharp> e'[y ::= x']"
    proof(cases "x = y")
    case False
      hence "atom x \<sharp> e'" using `atom x \<sharp> (\<Delta>, Lam [y]. e')`
        by (auto simp add:fresh_Pair)
      thus ?thesis using Application.prems
        by (auto intro: subst_pres_fresh[rule_format] simp add: fresh_Pair)
    next
    case True
      thus ?thesis using `atom x \<sharp> (\<Delta>, Lam [y]. e')` Application.prems
        by (auto intro:subst_is_fresh simp add: fresh_Pair)
    qed
    ultimately
    have "atom x \<sharp> (\<Delta>, e'[y::=x'])" by simp
    thus ?thesis by (rule Application.IH(2))
  next
    assume "x \<in> fdom \<Delta>  - set (x' # L)"
    thus ?thesis using reds_doesnt_forget[OF Application.hyps(3)] by auto
  qed
next
case (ApplicationInd y \<Gamma> e x' L u \<Delta> e' \<Theta> z)
  hence "atom x \<sharp> (\<Gamma>, e)" by (simp add: fresh_Pair)
  hence "atom x \<sharp> (\<Delta>, Lam [y]. e') \<or> x \<in> fdom \<Delta> - set (y # x' # L)"
    by (rule ApplicationInd.IH(1))
  thus ?case
  proof
    assume  "atom x \<sharp> (\<Delta>, Lam [y]. e')"
    show ?thesis
    proof(cases "x = y")
    case False
      from ApplicationInd.prems `atom x \<sharp> (\<Delta>, Lam [y]. e')` False
      have "atom x \<sharp> (\<Delta>(y f\<mapsto>  Var x') , e')" by (simp add: fresh_Pair fresh_Cons fresh_fmap_upd_eq fresh_fmap_delete_subset)
      thus ?thesis by (rule ApplicationInd.IH(2))
    next
    case True
      hence "x \<in> fdom (\<Delta>(y f\<mapsto>  Var x'))" by simp
      hence "x \<in> fdom \<Theta>" by (rule set_mp[OF reds_doesnt_forget[OF ApplicationInd.hyps(3)]])
      moreover
      have "atom x \<sharp> L" using True ApplicationInd by (simp add: fresh_Pair)
      hence "x \<notin> set L" by (metis fresh_list_elem not_self_fresh)
      ultimately
      show ?thesis by simp
    qed
  next
    assume "x \<in> fdom \<Delta>  - set (y # x' # L)"
    thus ?thesis using reds_doesnt_forget[OF ApplicationInd.hyps(3)] by auto
  qed
next

case(Variable \<Gamma> v e i L \<Delta> z)
  have "atom x \<sharp> \<Gamma>" and "atom x \<sharp> v" using Variable.prems(1) by (auto simp add: fresh_Pair)
  hence "atom x \<sharp> fmap_delete v \<Gamma>" and "atom x \<sharp> e" using `lookup \<Gamma> v = Some e`
    apply (auto intro: fresh_fmap_delete_subset dest:fresh_list_elem)
    by (metis fmap_upd_noop fresh_fmap_upd_eq lookup_fdom the.simps)
  hence "atom x \<sharp> (fmap_delete v \<Gamma>, e)" by (simp add: fresh_Pair)
  hence "atom x \<sharp> (\<Delta>, z) \<or> x \<in> fdom \<Delta> - set (v # L)"  by (rule Variable.IH)
  thus ?case using `atom x \<sharp> e` `atom x \<sharp> v`
    by (auto simp add: fresh_Pair fresh_Cons fresh_at_base fresh_fmap_upd_eq fresh_fmap_delete_subset)
next

case(VariableNoBH \<Gamma> v e i L \<Delta> z)
  have "atom x \<sharp> \<Gamma>" and "atom x \<sharp> v" using VariableNoBH.prems(1) by (auto simp add: fresh_Pair)
  hence "atom x \<sharp> \<Gamma>" and "atom x \<sharp> e" using `lookup \<Gamma> v = Some e`
    apply (auto) by (metis fmap_upd_noop fresh_fmap_upd_eq lookup_fdom the.simps)
  hence "atom x \<sharp> (\<Gamma>, e)" by (simp add: fresh_Pair)
  hence "atom x \<sharp> (\<Delta>, z) \<or> x \<in> fdom \<Delta> - set (v # L)"  by (rule VariableNoBH.IH)
  thus ?case using `atom x \<sharp> e` `atom x \<sharp> v`
    by (auto simp add: fresh_Pair fresh_Cons fresh_at_base fresh_fmap_upd_eq fresh_fmap_delete_subset)
next

case (Let as \<Gamma> L body \<Delta> z)
  show ?case
    proof (cases "atom x \<in> set(bn as)")
    case False
      hence "atom x \<sharp> as" using Let.prems by(auto simp add: fresh_Pair)
      hence "atom x \<sharp> asToHeap as"
        by (rule fresh_fun_eqvt_app[OF asToHeap_eqvt])
      show ?thesis
        apply(rule Let.IH)
        using Let.prems `atom x \<sharp> asToHeap as` False
        by (auto simp add: fresh_Pair fresh_append fresh_fun_merge_subset eqvt_fresh_cong1[OF fmap_of_eqvt])
    next
    case True
      hence "x \<in> fdom (fmap_of (asToHeap as))"
        by (simp add: fdom_fmap_of_conv_heapVars image_iff set_bn_to_atom_heapVars)
      moreover
      have "x \<notin> set L"
        using Let(1)
        by (metis True fresh_list_elem fresh_star_Pair fresh_star_def not_self_fresh)
      ultimately
      show ?thesis
      using reds_doesnt_forget[OF Let.hyps(2)] by auto
    qed
qed

lemma reds_fresh_L:" \<lbrakk> \<Gamma> : e \<Down>\<^sup>i\<^sup>u\<^bsub>L\<^esub> \<Delta> : z;
   atom (x::var) \<sharp> (\<Gamma>, e) ; x \<in> set L
  \<rbrakk> \<Longrightarrow> atom x \<sharp> (\<Delta>, z)"
  by (metis reds_fresh Diff_iff)

text {*
Reducing the set of variables to avoid is always possible.
*}

lemma fresh_set_subset: "x \<sharp> L \<Longrightarrow> set L' \<subseteq> set L \<Longrightarrow> x \<sharp> L'"
  by (induction L') (auto simp add: fresh_Cons fresh_Nil dest: fresh_list_elem)

lemma fresh_set_eq: "set L' = set L \<Longrightarrow> x \<sharp> L' \<longleftrightarrow> x \<sharp> L"
  by (metis fresh_set_subset order_refl)

lemma reds_smaller_L: "\<lbrakk> \<Gamma> : e \<Down>\<^sup>i\<^sup>u\<^bsub>L\<^esub> \<Delta> : z;
   set L' \<subseteq> set L
  \<rbrakk> \<Longrightarrow> \<Gamma> : e \<Down>\<^sup>i\<^sup>u\<^bsub>L'\<^esub> \<Delta> : z"
proof(nominal_induct avoiding : L' rule: reds.strong_induct)
case (Lambda \<Gamma> x e L L')
  show ?case
    by (rule LambdaI)
next
case (Application y \<Gamma> e x L \<Delta> \<Theta> z b e' L')
  show ?case
  proof(rule reds.Application)
    show "atom y \<sharp> (\<Gamma>, e, x, L', \<Delta>, \<Theta>, z)"
      using Application
      by (auto simp add: fresh_Pair dest: fresh_set_subset)

    have "set (x # L') \<subseteq> set (x # L)"
      using `set L' \<subseteq> set L` by auto
    thus "\<Gamma> : e \<Down>\<^sup>\<times>\<^sup>b\<^bsub>x # L'\<^esub> \<Delta> : Lam [y]. e'"
      by (rule Application.hyps(10))

    show "\<Delta> : e'[y ::= x] \<Down>\<^sup>\<times>\<^sup>b\<^bsub>L'\<^esub> \<Theta> : z "
      by (rule Application.hyps(12)[OF Application.prems])
  qed
next
case (ApplicationInd y \<Gamma> e x L u \<Delta> e' \<Theta> z L')
  show ?case
  proof(rule reds.ApplicationInd)
    show "atom y \<sharp> (\<Gamma>, e, x, L')"
      using ApplicationInd
      by (auto simp add: fresh_Pair dest: fresh_set_subset)

    have "set (y # x # L') \<subseteq> set (y # x # L)"
      using `set L' \<subseteq> set L` by auto
    thus "\<Gamma> : e \<Down>\<^sup>\<surd>\<^sup>u\<^bsub>y # x # L'\<^esub> \<Delta> : Lam [y]. e'"
      by (rule ApplicationInd.hyps(6))

    show "\<Delta>(y f\<mapsto> Var x) : e' \<Down>\<^sup>\<surd>\<^sup>u\<^bsub>L'\<^esub> \<Theta> : z "
      by (rule ApplicationInd.hyps(8)[OF ApplicationInd.prems])
  qed
next
case (Variable \<Gamma> x e i L \<Delta> z L')
  have "set (x # L') \<subseteq> set (x # L)"
    using Variable.prems by auto
  thus ?case
    by (rule reds.Variable[OF Variable(1) Variable.hyps(3)])
next
case (VariableNoBH \<Gamma> x e i L \<Delta> z L')
  have "set (x # L') \<subseteq> set (x # L)"
    using VariableNoBH.prems by auto
  thus ?case
    by (rule reds.VariableNoBH[OF VariableNoBH(1) VariableNoBH.hyps(3)])
next
case (Let as \<Gamma>  L body \<Delta> z L')
  have "set (bn as) \<sharp>* (\<Gamma>, L')"
    using Let(1-3) Let.prems
    by (auto simp add: fresh_star_Pair  fresh_star_set_subset)
  thus ?case
    by (rule reds.Let[OF _  Let.hyps(4)[OF Let.prems]])
qed

end


theory VTcomp
imports
  Array_Map_Default
  Dynamic_Array
  (*Impl_List_Set_Ndj*)
  Synth_Definition
  Exc_Nres_Monad
begin

no_notation Ref.lookup ("!_" 61)
no_notation Ref.update ("_ := _" 62)

section \<open>Added Stuff\<close>

lemma nfoldli_upt_rule:
  assumes INTV: "lb\<le>ub"
  assumes I0: "I lb \<sigma>0"
  assumes IS: "\<And>i \<sigma>. \<lbrakk> lb\<le>i; i<ub; I i \<sigma>; c \<sigma> \<rbrakk> \<Longrightarrow> f i \<sigma> \<le> SPEC (I (i+1))"
  assumes FNC: "\<And>i \<sigma>. \<lbrakk> lb\<le>i; i\<le>ub; I i \<sigma>; \<not>c \<sigma> \<rbrakk> \<Longrightarrow> P \<sigma>"
  assumes FC: "\<And>\<sigma>. \<lbrakk> I ub \<sigma>; c \<sigma> \<rbrakk> \<Longrightarrow> P \<sigma>"
  shows "nfoldli [lb..<ub] c f \<sigma>0 \<le> SPEC P"
  apply (rule nfoldli_rule[where I="\<lambda>l _ \<sigma>. I (lb+length l) \<sigma>"])
  apply simp_all
  apply (simp add: I0)
  subgoal using IS
    by (metis Suc_eq_plus1 add_diff_cancel_left' eq_diff_iff le_add1 length_upt upt_eq_lel_conv)
  subgoal for l1 l2 \<sigma>
    apply (rule FNC[where i="lb + length l1"])
    apply (auto simp: INTV)
    using INTV upt_eq_append_conv by auto
  apply (rule FC) using INTV
  by auto

term Refine_Basic.bind

abbreviation (do_notation) bind_doN where "bind_doN \<equiv> Refine_Basic.bind"

notation (output) bind_doN (infixr "\<bind>" 54)
notation (ASCII output) bind_doN (infixr ">>=" 54)

nonterminal doN_binds and doN_bind
syntax
  "_doN_block" :: "doN_binds \<Rightarrow> 'a" ("doN {//(2  _)//}" [12] 62)
  "_doN_bind"  :: "[pttrn, 'a] \<Rightarrow> doN_bind" ("(2_ \<leftarrow>/ _)" 13)
  "_doN_let" :: "[pttrn, 'a] \<Rightarrow> doN_bind" ("(2let _ =/ _)" [1000, 13] 13)
  "_doN_then" :: "'a \<Rightarrow> doN_bind" ("_" [14] 13)
  "_doN_final" :: "'a \<Rightarrow> doN_binds" ("_")
  "_doN_cons" :: "[doN_bind, doN_binds] \<Rightarrow> doN_binds" ("_;//_" [13, 12] 12)
  "_thenM" :: "['a, 'b] \<Rightarrow> 'c" (infixr "\<then>" 54)

syntax (ASCII)
  "_doN_bind" :: "[pttrn, 'a] \<Rightarrow> doN_bind" ("(2_ <-/ _)" 13)
  "_thenM" :: "['a, 'b] \<Rightarrow> 'c" (infixr ">>" 54)

translations
  "_doN_block (_doN_cons (_doN_then t) (_doN_final e))"
    \<rightleftharpoons> "CONST bind_doN t (\<lambda>_. e)"
  "_doN_block (_doN_cons (_doN_bind p t) (_doN_final e))"
    \<rightleftharpoons> "CONST bind_doN t (\<lambda>p. e)"
  "_doN_block (_doN_cons (_doN_let p t) bs)"
    \<rightleftharpoons> "let p = t in _doN_block bs"
  "_doN_block (_doN_cons b (_doN_cons c cs))"
    \<rightleftharpoons> "_doN_block (_doN_cons b (_doN_final (_doN_block (_doN_cons c cs))))"
  "_doN_cons (_doN_let p t) (_doN_final s)"
    \<rightleftharpoons> "_doN_final (let p = t in s)"
  "_doN_block (_doN_final e)" \<rightharpoonup> "e"
  "(m \<then> n)" \<rightharpoonup> "(m \<bind> (\<lambda>_. n))"

definition [enres_unfolds]: "efor (lb::int) ub f \<sigma> \<equiv> doE {
  EASSERT (lb\<le>ub);
  (_,\<sigma>) \<leftarrow> EWHILET (\<lambda>(i,\<sigma>). i<ub) (\<lambda>(i,\<sigma>). doE { \<sigma> \<leftarrow> f i \<sigma>; ERETURN (i+1,\<sigma>) }) (lb,\<sigma>);
  ERETURN \<sigma>
}"

thm EWHILEIT_rule

lemma efor_rule:
  assumes INTV: "lb\<le>ub"
  assumes I0: "I lb \<sigma>0"
  assumes IS: "\<And>i \<sigma>. \<lbrakk> lb\<le>i; i<ub; I i \<sigma> \<rbrakk> \<Longrightarrow> f i \<sigma> \<le> ESPEC E (I (i+1))"
  assumes FC: "\<And>\<sigma>. \<lbrakk> I ub \<sigma> \<rbrakk> \<Longrightarrow> P \<sigma>"
  shows "efor lb ub f \<sigma>0 \<le> ESPEC E P"
  unfolding efor_def
  supply EWHILET_rule[where R="measure (\<lambda>(i,_). nat (ub-i))" and I="\<lambda>(i,\<sigma>). lb\<le>i \<and> i\<le>ub \<and> I i \<sigma>", refine_vcg]
  apply refine_vcg
  apply auto
  using assms apply auto
  done

end


theory Setup
  imports
    Isabelle_LLVM.LLVM_DS_All
    Abstract_Rbt
    "Separation_Logic_Solver/Methods"
begin

subsection \<open>RBT NODE Datatype\<close>

text_raw \<open>\snip{rbtnodedef}{1}{2}{%\<close>
datatype ('k :: llvm_rep, 'v :: llvm_rep) rbt_node =
  RBT_NODE
  (color: "8 word")
  (left: "('k, 'v) rbt_node ptr")
  (key: 'k)
  (val: 'v)
  (right: "('k, 'v) rbt_node ptr")
text_raw \<open>}%endsnip\<close>

hide_const (open) color left key val right

type_synonym ('k, 'v) rbti = "('k, 'v) rbt_node ptr"

subsubsection \<open>Encoding to heap-representable\<close>

instantiation rbt_node :: (llvm_rep, llvm_rep) llvm_rep
begin

fun to_val_rbt_node where
  "to_val_rbt_node (RBT_NODE col l_child k v r_child) =
    LL_STRUCT [to_val col, to_val l_child, to_val k, to_val v, to_val r_child]"

fun from_val_rbt_node where
  "from_val_rbt_node (LL_STRUCT [col, l_child_rep, k_rep, v_rep, r_child_rep]) =
    RBT_NODE (from_val col)
             (from_val l_child_rep)
             (from_val k_rep)
             (from_val v_rep)
             (from_val r_child_rep)"
| "from_val_rbt_node _ = undefined"

definition "struct_of_rbt_node (_::('a, 'b) rbt_node itself) =
    VS_STRUCT [VS_INT 8, VS_PTR, struct_of TYPE('a), struct_of TYPE('b), VS_PTR]"

definition "init_rbt_node \<equiv> RBT_NODE init init init init init"

instance
proof(standard, goal_cases)
  case 1
  then show ?case unfolding comp_def id_def
  proof
    fix x:: "('a,'b) rbt_node"
    show "from_val (to_val x) = x" by (cases x; simp)
  qed
next
  case (2 v)
  then show ?case
    unfolding struct_of_rbt_node_def
    by (cases v rule: from_val_rbt_node.cases; simp)
next
  case (3 x)
  then show ?case
    unfolding struct_of_rbt_node_def
    by (cases x; simp)
next
  case 4
  then show ?case
    by (simp add: init_zero init_rbt_node_def struct_of_rbt_node_def to_val_word_def to_val_ptr_def null_def)
qed
end

subsubsection \<open>Setup for LLVM code export\<close>
text \<open>Declare structure to code generator.\<close>
lemma to_val_rbt_node [ll_struct_of]:
  "struct_of TYPE(('k::llvm_rep, 'v::llvm_rep) rbt_node) =
      VS_STRUCT
      [
        struct_of TYPE(8 word),
        struct_of TYPE(('k, 'v) rbt_node ptr),
        struct_of TYPE('k),
        struct_of TYPE('v),
        struct_of TYPE(('k, 'v) rbt_node ptr)
      ]"
  unfolding struct_of_rbt_node_def
  by auto

text \<open>Declare as named structure. Required b/c of circular reference.\<close>
lemma [ll_identified_structures]:
  "ll_is_identified_structure ''rbt_node'' TYPE((_, _) rbt_node)"
  unfolding ll_is_identified_structure_def
    struct_of_rbt_node_def
  by simp

subsubsection \<open>Code Generator Preprocessor Setup\<close>
text \<open>The next two are auxiliary lemmas\<close>
lemma rbt_node_insert_value [simp]:
  "ll_insert_value (RBT_NODE c l k v r) ci 0 = Mreturn (RBT_NODE ci l k v r)"
  "ll_insert_value (RBT_NODE c l k v r) li (Suc 0) = Mreturn (RBT_NODE c li k v r)"
  "ll_insert_value (RBT_NODE c l k v r) ki 2 = Mreturn (RBT_NODE c l ki v r)"
  "ll_insert_value (RBT_NODE c l k v r) vi 3 = Mreturn (RBT_NODE c l k vi r)"
  "ll_insert_value (RBT_NODE c l k v r) ri 4 = Mreturn (RBT_NODE c l k v ri)"
  by (simp_all add:
      ll_insert_value_def llvm_insert_value_def
      Let_def checked_from_val_def struct_of_rbt_node_def)

lemma rbt_node_extract_value [simp]:
  "ll_extract_value (RBT_NODE c l k v r) 0 = Mreturn c"
  "ll_extract_value (RBT_NODE c l k v r) (Suc 0) = Mreturn l"
  "ll_extract_value (RBT_NODE c l k v r) 2 = Mreturn k"
  "ll_extract_value (RBT_NODE c l k v r) 3 = Mreturn v"
  "ll_extract_value (RBT_NODE c l k v r) 4 = Mreturn r"
  by (simp_all add:
      ll_extract_value_def llvm_extract_value_def Let_def checked_from_val_def)

text \<open>Lemmas to translate node construction and destruction\<close>
lemma inline_return_node [llvm_pre_simp]: "Mreturn (RBT_NODE c l k v r) =
   doM {
    res \<leftarrow> ll_insert_value init c 0;
    res \<leftarrow> ll_insert_value res l 1;
    res \<leftarrow> ll_insert_value res k 2;
    res \<leftarrow> ll_insert_value res v 3;
    res \<leftarrow> ll_insert_value res r 4;
    Mreturn res
  }"
  by (auto simp: init_rbt_node_def)

lemma inline_node_case [llvm_pre_simp]: "
  (case x of (RBT_NODE c l k v r) \<Rightarrow> f c l k v r) =
   doM {
    c \<leftarrow> ll_extract_value x 0;
    l \<leftarrow> ll_extract_value x 1;
    k \<leftarrow> ll_extract_value x 2;
    v \<leftarrow> ll_extract_value x 3;
    r \<leftarrow> ll_extract_value x 4;
    f c l k v r
  }"
  apply (cases x)
  by auto

lemma inline_return_node_case [llvm_pre_simp]:
  "Mreturn (case x of (RBT_NODE c l k v r) \<Rightarrow> f c l k v r) =
  doM {
    c \<leftarrow> ll_extract_value x 0;
    l \<leftarrow> ll_extract_value x 1;
    k \<leftarrow> ll_extract_value x 2;
    v \<leftarrow> ll_extract_value x 3;
    r \<leftarrow> ll_extract_value x 4;
    Mreturn (f c l k v r)
  }"
  apply (cases x)
  by auto

lemmas [llvm_inline] =
  rbt_node.color_def
  rbt_node.left_def
  rbt_node.key_def
  rbt_node.val_def
  rbt_node.right_def

subsubsection \<open>Setters\<close>

definition set_color ::
  "('k::llvm_rep, 'v::llvm_rep) rbt_node \<Rightarrow> 8 word \<Rightarrow> _"
  where "set_color node col \<equiv> ll_insert_value node col 0"
definition set_left ::
  "('k::llvm_rep, 'v::llvm_rep) rbt_node \<Rightarrow> ('k, 'v) rbti \<Rightarrow> _"
  where "set_left node lhs \<equiv> ll_insert_value node lhs 1"
definition set_key ::
  "('k::llvm_rep, 'v::llvm_rep) rbt_node \<Rightarrow> 'k \<Rightarrow> _"
  where "set_key node k \<equiv> ll_insert_value node k 2"
definition set_value ::
  "('k::llvm_rep, 'v::llvm_rep) rbt_node \<Rightarrow> 'v \<Rightarrow> _"
  where "set_value node v \<equiv> ll_insert_value node v 3"
definition set_right ::
  "('k::llvm_rep, 'v::llvm_rep) rbt_node \<Rightarrow> ('k, 'v) rbti \<Rightarrow> _"
  where "set_right node rhs \<equiv> ll_insert_value node rhs 4"

definition [llvm_pre_simp, simp]:
  "mod_ptr f n_p \<equiv>
  doM {
    n_pre \<leftarrow> ll_load n_p;
    n_post \<leftarrow> f n_pre;
    ll_store n_post n_p
  }"

definition "set_color_p x \<equiv> mod_ptr (\<lambda>n. set_color n x)"
definition "set_left_p x \<equiv> mod_ptr (\<lambda>n. set_left n x)"
definition "set_key_p x \<equiv> mod_ptr (\<lambda>n. set_key n x)"
definition "set_value_p x \<equiv> mod_ptr (\<lambda>n. set_value n x)"
definition "set_right_p x \<equiv> mod_ptr (\<lambda>n. set_right n x)"

lemmas [llvm_inline, simp] =
  set_color_def
  set_left_def
  set_key_def
  set_value_def
  set_right_def

set_color_p_def
set_left_p_def
set_key_p_def
set_value_p_def
set_right_p_def

subsection \<open>Color Assertion\<close>

fun color_pred where
  "color_pred color.R ci = (ci = 0)"
| "color_pred color.B ci = (ci = 1)"

abbreviation "color_assn c ci \<equiv> \<up>(color_pred c ci)"

lemma color_assn_R_0 [fri_red_rules]:
  "is_sep_red \<box> \<box> \<box> (color_assn color.R 0)"
  apply (rule is_sep_redI)
  apply sep
  by simp_all

lemma color_assn_B_1 [fri_red_rules]:
  "is_sep_red \<box> \<box> \<box> (color_assn color.B 1)"
  apply (rule is_sep_redI)
  apply sep
  by simp_all

subsection \<open>Linorder Locale\<close>

locale linorder_impl =
  fixes
    abs_type :: "'a :: linorder itself" and
    conc_type :: "'ai :: llvm_rep itself" and
    lt_impl :: "'ai \<Rightarrow> 'ai \<Rightarrow> 1 word llM" and
    elem_assn :: "('a, 'ai) dr_assn"
  assumes lt_impl_rule [vcg_rules]:
    "llvm_htriple
            (\<upharpoonleft>elem_assn l li ** \<upharpoonleft>elem_assn r ri)
            (lt_impl li ri)
            (\<lambda>res.
              \<upharpoonleft>bool.assn (l < r) res **
              \<upharpoonleft>elem_assn l li **
              \<upharpoonleft>elem_assn r ri)"

subsection \<open>RBT Locale\<close>

locale monad_syntax_M_loc
begin

unbundle monad_syntax_M

end

locale rbt_impl_deps =
  monad_syntax_M_loc +
  llvm_prim_ctrl_setup +
  llvm_prim_arith_setup +
  llvm_prim_setup

locale rbt_impl =
  linorder_impl key_type key_type_i lt_impl key_assn
  for
    key_type :: "'k :: linorder itself" and
    key_type_i :: "'ki :: llvm_rep itself" and
    value_type :: "'v itself" and
    value_type_i :: "'vi :: llvm_rep itself" and

lt_impl and
key_assn and
key_free :: "'ki \<Rightarrow> unit llM" and
value_assn :: "('v, 'vi) dr_assn" and
value_free :: "'vi \<Rightarrow> unit llM" +
assumes
  key_free_rule [vcg_rules]:
  "
      llvm_htriple
      (\<upharpoonleft>key_assn k ki)
      (key_free ki)
      (\<lambda>_. \<box>)
    " and
  value_free_rule [vcg_rules]:
  "
      llvm_htriple
      (\<upharpoonleft>value_assn v vi)
      (value_free vi)
      (\<lambda>_. \<box>)
    "
begin
interpretation rbt_impl_deps .

subsection \<open>RBT Assertion\<close>

fun rbt_assn :: "
  ('k, 'v) rbt \<Rightarrow>
  ('ki, 'vi) rbti \<Rightarrow>
  ll_assn
" where
  "rbt_assn rbt.Empty p = \<up>(p=null)"
| "rbt_assn (rbt.Branch c l k v r) p = (
    EXS ci li ki vi ri.
      \<upharpoonleft>ll_bpto (RBT_NODE ci li ki vi ri) p **
      color_assn c ci **
      rbt_assn l li **
      \<upharpoonleft>key_assn k ki **
      \<upharpoonleft>value_assn v vi **
      rbt_assn r ri
  )"
declare rbt_assn.simps(2)[simp del]
lemmas rbt_assn_unfold = rbt_assn.simps(2)

fun rbt_assn_full where "rbt_assn_full t ti = (rbt_assn t ti ** \<up>(is_rbt t))"

lemma rbt_sorted_key_uniqI:
  "rbt_sorted (Branch c l k v r) \<Longrightarrow> k \<notin> set (RBT_Impl.keys l)"
  "rbt_sorted (Branch c l k v r) \<Longrightarrow> k \<notin> set (RBT_Impl.keys r)"
   apply simp_all
  unfolding rbt_less_prop rbt_greater_prop
  by blast+

lemma rbt_sorted_subtrees_disjoint:
  "rbt_sorted (Branch c l k v r) \<Longrightarrow> set (RBT_Impl.keys l) \<inter> set (RBT_Impl.keys r) = {}"
  apply simp
  unfolding rbt_less_prop rbt_greater_prop
  by fastforce

lemma [simp]: "rbt_assn_full t null = \<up>(t=rbt.Empty)"
  by (cases t; simp add: pure_true_conv)

subsection \<open>Load Rule\<close>

lemma load_rbt [vcg_rules]:
  "
    llvm_htriple
    (rbt_assn (Branch c l k v r) ti)
    (ll_load ti)
    (\<lambda>res.
      EXS ci li ki vi ri.
        \<upharpoonleft>ll_bpto res ti **
        color_assn c ci **
        rbt_assn l li **
        \<upharpoonleft>key_assn k ki **
        \<upharpoonleft>value_assn v vi **
        rbt_assn r ri **
        \<up>(res = RBT_NODE ci li ki vi ri)
    )
  "
  unfolding rbt_assn_unfold
  apply vcg
  done

lemma load_rbt_non_null [vcg_rules]:
  "
    llvm_htriple
    (rbt_assn t ti ** \<up>(ti \<noteq> null))
    (ll_load ti)
    (\<lambda>res.
      EXS ci li ki vi ri c l k v r.
        \<upharpoonleft>ll_bpto res ti **
        color_assn c ci **
        rbt_assn l li **
        \<upharpoonleft>key_assn k ki **
        \<upharpoonleft>value_assn v vi **
        rbt_assn r ri **
        \<up>(res = RBT_NODE ci li ki vi ri) **
        \<up>(t = rbt.Branch c l k v r))
  "
  apply vcg
  apply (cases t)
  subgoal by (simp add: rbt_assn_unfold) (*contradiction*)
  subgoal by vcg
  done

subsection \<open>Reduction Rules\<close>

lemma unfold_rbt_assn_red_rule [fri_red_rules]:
  "
    is_sep_red
    \<box>
    (color_assn c ci \<and>* rbt_assn l li \<and>* \<upharpoonleft>key_assn k ki \<and>* \<upharpoonleft>value_assn v vi \<and>* rbt_assn r ri)
    (\<upharpoonleft>ll_bpto (RBT_NODE ci li ki vi ri) ti)
    (rbt_assn (rbt.Branch c l k v r) ti)
  "
  apply (rule is_sep_redI)
  apply (simp add: rbt_assn_unfold)
  subgoal premises prems for Ps Qs
    apply (sepE isep_dest: prems)
      (*
    apply (sep_drule prems)
    apply (simp only: fri_extract_simps entails_lift_extract_simps cong: entails_pre_cong)
    apply clarify
    apply fri
    *)
    done
  done

subsection \<open>Empty Constructor\<close>

definition empty :: "('ki, 'vi) rbti llM"
  where [llvm_code]: "empty \<equiv> Mreturn null"

lemma empty_correct [vcg_rules]:
  "llvm_htriple
   \<box>
   empty
   (\<lambda> r. rbt_assn rbt.Empty r)"
  unfolding empty_def
  by vcg

end

end


(*  Title:      JinjaThreads/Execute/TypeRelRefine.thy
    Author:     Andreas Lochbihler

    Tabulation for lookup functions
*)

section \<open>Tabulation for lookup functions\<close>

theory TypeRelRefine
imports
  "../Common/TypeRel"
  "HOL-Library.AList_Mapping"
begin

subsection \<open>Auxiliary lemmata\<close>

lemma map_of_map2: "map_of (map (\<lambda>(k, v). (k, f k v)) xs) k = map_option (f k) (map_of xs k)"
by(induct xs) auto

lemma map_of_map_K: "map_of (map (\<lambda>k. (k, c)) xs) k = (if k \<in> set xs then Some c else None)"
by(induct xs) auto

lift_definition map_values :: "('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> ('a, 'b) mapping \<Rightarrow> ('a, 'c) mapping"
is "\<lambda>f m k. map_option (f k) (m k)" .

lemma map_Mapping: "Mapping.map f g (Mapping.Mapping m) = Mapping.Mapping (map_option g \<circ> m \<circ> f)"
by(rule map.abs_eq)

abbreviation subclst :: "'m prog \<Rightarrow> cname \<Rightarrow> cname \<Rightarrow> bool"
where "subclst P \<equiv> (subcls1 P)^++"

subsection \<open>Representation type for tabulated lookup functions\<close>

type_synonym
  'm prog_impl' =
  "'m cdecl list \<times>
   (cname, 'm class) mapping \<times>
   (cname, cname set) mapping \<times>
   (cname, (vname, cname \<times> ty \<times> fmod) mapping) mapping \<times>
   (cname, (mname, cname \<times> ty list \<times> ty \<times> 'm option) mapping) mapping"

lift_definition tabulate_class :: "'m cdecl list \<Rightarrow> (cname, 'm class) mapping"
is "class \<circ> Program" .

lift_definition tabulate_subcls :: "'m cdecl list \<Rightarrow> (cname, cname set) mapping"
is "\<lambda>P C. if is_class (Program P) C then Some {D. Program P \<turnstile> C \<preceq>\<^sup>* D} else None" .

lift_definition tabulate_sees_field :: "'m cdecl list \<Rightarrow> (cname, (vname, cname \<times> ty \<times> fmod) mapping) mapping"
is "\<lambda>P C. if is_class (Program P) C then
        Some (\<lambda>F. if \<exists>T fm D. Program P \<turnstile> C sees F:T (fm) in D then Some (field (Program P) C F) else None)
      else None" .

lift_definition tabulate_Method :: "'m cdecl list \<Rightarrow> (cname, (mname, cname \<times> ty list \<times> ty \<times> 'm option) mapping) mapping"
is "\<lambda>P C. if is_class (Program P) C then
         Some (\<lambda>M. if \<exists>Ts T mthd D. Program P \<turnstile> C sees M:Ts\<rightarrow>T=mthd in D then Some (method (Program P) C M) else None)
      else None" .

fun wf_prog_impl' :: "'m prog_impl' \<Rightarrow> bool"
where
  "wf_prog_impl' (P, c, s, f, m) \<longleftrightarrow>
  c = tabulate_class P \<and>
  s = tabulate_subcls P \<and>
  f = tabulate_sees_field P \<and>
  m = tabulate_Method P"

subsection \<open>Implementation type for tabulated lookup functions\<close>

typedef 'm prog_impl = "{P :: 'm prog_impl'. wf_prog_impl' P}"
  morphisms impl_of ProgRefine
proof
  show "([], Mapping.empty, Mapping.empty, Mapping.empty, Mapping.empty) \<in> ?prog_impl"
    apply clarsimp
    by transfer (simp_all add: fun_eq_iff is_class_def rel_funI)
qed

lemma impl_of_ProgImpl [simp]:
  "wf_prog_impl' Pfsm \<Longrightarrow> impl_of (ProgRefine Pfsm) = Pfsm"
by(simp add: ProgRefine_inverse)

definition program :: "'m prog_impl \<Rightarrow> 'm prog"
where "program = Program \<circ> fst \<circ> impl_of"

code_datatype program

lemma prog_impl_eq_iff:
  "Pi = Pi' \<longleftrightarrow> program Pi = program Pi'" for Pi Pi'
apply(cases Pi)
apply(cases Pi')
apply(auto simp add: ProgRefine_inverse program_def ProgRefine_inject)
done

lemma wf_prog_impl'_impl_of [simp, intro!]:
  "wf_prog_impl' (impl_of Pi)" for Pi
using impl_of[of Pi] by simp

lemma ProgImpl_impl_of [simp, code abstype]:
  "ProgRefine (impl_of Pi) = Pi" for Pi
by(rule impl_of_inverse)

lemma program_ProgRefine [simp]: "wf_prog_impl' Psfm \<Longrightarrow> program (ProgRefine Psfm) = Program (fst Psfm)"
by(simp add: program_def)

lemma classes_program [code]: "classes (program P) = fst (impl_of P)"
by(simp add: program_def)

lemma class_program [code]: "class (program Pi) = Mapping.lookup (fst (snd (impl_of Pi)))" for Pi
by(cases Pi)(clarsimp simp add: tabulate_class_def lookup.rep_eq Mapping_inverse)

subsection \<open>Refining sub class and lookup functions to use precomputed mappings\<close>

declare subcls'.equation [code del]

lemma subcls'_program [code]:
  "subcls' (program Pi) C D \<longleftrightarrow>
  C = D \<or>
  (case Mapping.lookup (fst (snd (snd (impl_of Pi)))) C of None \<Rightarrow> False
   | Some m \<Rightarrow> D \<in> m)" for Pi
apply(cases Pi)
apply(clarsimp simp add: subcls'_def tabulate_subcls_def lookup.rep_eq Mapping_inverse)
apply(auto elim!: rtranclp_tranclpE dest: subcls_is_class intro: tranclp_into_rtranclp)
done

lemma subcls'_i_i_i_program [code]:
  "subcls'_i_i_i P C D = (if subcls' P C D then Predicate.single () else bot)"
by(rule pred_eqI)(auto elim: subcls'_i_i_iE intro: subcls'_i_i_iI)

lemma subcls'_i_i_o_program [code]:
  "subcls'_i_i_o (program Pi) C =
  sup (Predicate.single C) (case Mapping.lookup (fst (snd (snd (impl_of Pi)))) C of None \<Rightarrow> bot | Some m \<Rightarrow> pred_of_set m)" for Pi
by(cases Pi)(fastforce simp add: subcls'_i_i_o_def subcls'_def tabulate_subcls_def lookup.rep_eq Mapping_inverse intro!: pred_eqI split: if_split_asm elim: rtranclp_tranclpE dest: subcls_is_class intro: tranclp_into_rtranclp)

lemma rtranclp_FioB_i_i_subcls1_i_i_o_code [code_unfold]:
  "rtranclp_FioB_i_i (subcls1_i_i_o P) = subcls'_i_i_i P"
by(auto simp add: fun_eq_iff subcls1_i_i_o_def subcls'_def rtranclp_FioB_i_i_def subcls'_i_i_i_def)

declare Method.equation[code del]
lemma Method_program [code]:
  "program Pi \<turnstile> C sees M:Ts\<rightarrow>T=meth in D \<longleftrightarrow>
  (case Mapping.lookup (snd (snd (snd (snd (impl_of Pi))))) C of
    None \<Rightarrow> False
  | Some m \<Rightarrow>
    (case Mapping.lookup m M of
       None \<Rightarrow> False
     | Some (D', Ts', T', meth') \<Rightarrow> Ts = Ts' \<and> T = T' \<and> meth = meth' \<and> D = D'))" for Pi
by(cases Pi)(auto split: if_split_asm dest: sees_method_is_class simp add: tabulate_Method_def lookup.rep_eq Mapping_inverse)

lemma Method_i_i_i_o_o_o_o_program [code]:
  "Method_i_i_i_o_o_o_o (program Pi) C M =
  (case Mapping.lookup (snd (snd (snd (snd (impl_of Pi))))) C of
    None \<Rightarrow> bot
  | Some m \<Rightarrow>
    (case Mapping.lookup m M of
      None \<Rightarrow> bot
    | Some (D, Ts, T, meth) \<Rightarrow> Predicate.single (Ts, T, meth, D)))" for Pi
by(auto simp add: Method_i_i_i_o_o_o_o_def Method_program intro!: pred_eqI)

lemma Method_i_i_i_o_o_o_i_program [code]:
  "Method_i_i_i_o_o_o_i (program Pi) C M D =
  (case Mapping.lookup (snd (snd (snd (snd (impl_of Pi))))) C of
    None \<Rightarrow> bot
  | Some m \<Rightarrow>
    (case Mapping.lookup m M of
      None \<Rightarrow> bot
    | Some (D', Ts, T, meth) \<Rightarrow> if D = D' then Predicate.single (Ts, T, meth) else bot))" for Pi
by(auto simp add: Method_i_i_i_o_o_o_i_def Method_program intro!: pred_eqI)

declare sees_field.equation[code del]

lemma sees_field_program [code]:
  "program Pi \<turnstile> C sees F:T (fd) in D \<longleftrightarrow>
  (case Mapping.lookup (fst (snd (snd (snd (impl_of Pi))))) C of
    None \<Rightarrow> False
  | Some m \<Rightarrow>
    (case Mapping.lookup m F of
       None \<Rightarrow> False
     | Some (D', T', fd') \<Rightarrow> T = T' \<and> fd = fd' \<and> D = D'))" for Pi
by(cases Pi)(auto split: if_split_asm dest: has_visible_field[THEN has_field_is_class] simp add: tabulate_sees_field_def lookup.rep_eq Mapping_inverse)

lemma sees_field_i_i_i_o_o_o_program [code]:
  "sees_field_i_i_i_o_o_o (program Pi) C F =
  (case Mapping.lookup (fst (snd (snd (snd (impl_of Pi))))) C of
    None \<Rightarrow> bot
  | Some m \<Rightarrow>
    (case Mapping.lookup m F of
       None \<Rightarrow> bot
    | Some (D, T, fd) \<Rightarrow> Predicate.single(T, fd, D)))" for Pi
by(auto simp add: sees_field_program sees_field_i_i_i_o_o_o_def intro: pred_eqI)

lemma sees_field_i_i_i_o_o_i_program [code]:
  "sees_field_i_i_i_o_o_i (program Pi) C F D =
  (case Mapping.lookup (fst (snd (snd (snd (impl_of Pi))))) C of
    None \<Rightarrow> bot
  | Some m \<Rightarrow>
    (case Mapping.lookup m F of
       None \<Rightarrow> bot
    | Some (D', T, fd) \<Rightarrow> if D = D' then Predicate.single(T, fd) else bot))" for Pi
by(auto simp add: sees_field_program sees_field_i_i_i_o_o_i_def intro: pred_eqI)

lemma field_program [code]:
  "field (program Pi) C F =
  (case Mapping.lookup (fst (snd (snd (snd (impl_of Pi))))) C of
    None \<Rightarrow> Code.abort (STR ''not_unique'') (\<lambda>_. Predicate.the bot)
  | Some m \<Rightarrow>
    (case Mapping.lookup m F of
       None \<Rightarrow> Code.abort (STR ''not_unique'') (\<lambda>_. Predicate.the bot)
     | Some (D', T, fd) \<Rightarrow> (D', T, fd)))" for Pi
unfolding field_def
by(cases Pi)(fastforce simp add: Predicate.the_def tabulate_sees_field_def lookup.rep_eq Mapping_inverse split: if_split_asm intro: arg_cong[where f=The] dest: has_visible_field[THEN has_field_is_class] sees_field_fun)

subsection \<open>Implementation for precomputing mappings\<close>

definition tabulate_program :: "'m cdecl list \<Rightarrow> 'm prog_impl"
where "tabulate_program P = ProgRefine (P, tabulate_class P, tabulate_subcls P, tabulate_sees_field P, tabulate_Method P)"

lemma impl_of_tabulate_program [code abstract]:
  "impl_of (tabulate_program P) = (P, tabulate_class P, tabulate_subcls P, tabulate_sees_field P, tabulate_Method P)"
by(simp add: tabulate_program_def)

lemma Program_code [code]:
  "Program = program \<circ> tabulate_program"
by(simp add: program_def fun_eq_iff tabulate_program_def)

subsubsection \<open>@{term "class" }\<close>

lemma tabulate_class_code [code]:
  "tabulate_class = Mapping.of_alist"
  by transfer (simp add: fun_eq_iff)

subsubsection \<open>@{term "subcls" }\<close>

inductive subcls1' :: "'m cdecl list \<Rightarrow> cname \<Rightarrow> cname \<Rightarrow> bool"
where
  find: "C \<noteq> Object \<Longrightarrow> subcls1' ((C, D, rest) # P) C D"
| step: "\<lbrakk> C \<noteq> Object; C \<noteq> C'; subcls1' P C D  \<rbrakk> \<Longrightarrow> subcls1' ((C', D', rest) # P) C D"

code_pred
  (modes: i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> bool)
  subcls1' .

lemma subcls1_into_subcls1':
  assumes "subcls1 (Program P) C D"
  shows "subcls1' P C D"
proof -
  from assms obtain rest where "map_of P C = \<lfloor>(D, rest)\<rfloor>" "C \<noteq> Object" by cases simp
  thus ?thesis by(induct P)(auto split: if_split_asm intro: subcls1'.intros)
qed

lemma subcls1'_into_subcls1:
  assumes "subcls1' P C D"
  shows "subcls1 (Program P) C D"
using assms
proof(induct)
  case find thus ?case by(auto intro: subcls1.intros)
next
  case step thus ?case by(auto elim!: subcls1.cases intro: subcls1.intros)
qed

lemma subcls1_eq_subcls1':
  "subcls1 (Program P) = subcls1' P"
by(auto simp add: fun_eq_iff intro: subcls1_into_subcls1' subcls1'_into_subcls1)

definition subcls'' :: "'m cdecl list \<Rightarrow> cname \<Rightarrow> cname \<Rightarrow> bool"
where "subcls'' P = (subcls1' P)^**"

code_pred
  (modes: i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> bool)
  [inductify]
  subcls'' .

lemma subcls''_eq_subcls: "subcls'' P = subcls (Program P)"
by(simp add: subcls''_def subcls1_eq_subcls1')

lemma subclst_snd_classD:
  assumes "subclst (Program P) C D"
  shows "D \<in> fst ` snd ` set P"
using assms
by(induct)(fastforce elim!: subcls1.cases dest!: map_of_SomeD intro: rev_image_eqI)+

definition check_acyclicity :: "(cname, cname set) mapping \<Rightarrow> 'm cdecl list \<Rightarrow> unit"
where "check_acyclicity _ _ = ()"

definition cyclic_class_hierarchy :: unit
where [code del]: "cyclic_class_hierarchy = ()"

declare [[code abort: cyclic_class_hierarchy]]

lemma check_acyclicity_code:
  "check_acyclicity mapping P =
   (let _ =
     map (\<lambda>(C, D, _).
       if C = Object then ()
       else
         (case Mapping.lookup mapping D of
            None \<Rightarrow> ()
          | Some Cs \<Rightarrow> if C \<in> Cs then cyclic_class_hierarchy else ()))
       P
    in ())"
by simp

lemma tablulate_subcls_code [code]:
  "tabulate_subcls P =
  (let cnames = map fst P;
       cnames' = map (fst \<circ> snd) P;
       mapping = Mapping.tabulate cnames (\<lambda>C. set (C # [D \<leftarrow> cnames'. subcls'' P C D]));
       _ = check_acyclicity mapping P
   in mapping
  )"
apply(auto simp add: tabulate_subcls_def Mapping.tabulate_def fun_eq_iff is_class_def o_def map_of_map2[simplified split_def] Mapping_inject)
 apply(subst map_of_map2[simplified split_def])
 apply(auto simp add: fun_eq_iff subcls''_eq_subcls map_of_map_K dest: subclst_snd_classD elim: rtranclp_tranclpE)[1]
apply(subst map_of_map2[simplified split_def])
apply(rule sym)
apply simp
apply(case_tac "map_of P x")
apply auto
done

subsubsection \<open>@{term Fields}\<close>

text \<open>
  Problem: Does not terminate for cyclic class hierarchies!
  This problem already occurs in Jinja's well-formedness checker:
  \<open>wf_cdecl\<close> calls \<open>wf_mdecl\<close> before checking for acyclicity,
  but \<open>wf_J_mdecl\<close> involves the type judgements,
  which in turn requires @{term "Fields"} (via @{term sees_field}).
  Checking acyclicity before executing @{term "Fields'"} for tabulation is difficult
  because we would have to intertwine tabulation and well-formedness checking.
  Possible (local) solution:
  additional termination parameter (like memoisation for @{term "rtranclp"})
  and list option as error return parameter.
\<close>
inductive
  Fields' :: "'m cdecl list \<Rightarrow> cname \<Rightarrow> ((vname \<times> cname) \<times> (ty \<times> fmod)) list \<Rightarrow> bool"
for P :: "'m cdecl list"
where
  rec:
  "\<lbrakk> map_of P C = Some(D,fs,ms); C \<noteq> Object; Fields' P D FDTs;
     FDTs' = map (\<lambda>(F,Tm). ((F,C),Tm)) fs @ FDTs \<rbrakk>
  \<Longrightarrow> Fields' P C FDTs'"
| Object:
  "\<lbrakk> map_of P Object = Some(D,fs,ms); FDTs = map (\<lambda>(F,T). ((F,Object),T)) fs \<rbrakk>
  \<Longrightarrow> Fields' P Object FDTs"

lemma Fields'_into_Fields:
  assumes "Fields' P C FDTs"
  shows "Program P \<turnstile> C has_fields FDTs"
using assms
by induct(auto intro: Fields.intros)

lemma Fields_into_Fields':
  assumes "Program P \<turnstile> C has_fields FDTs"
  shows "Fields' P C FDTs"
using assms
by induct(auto intro: Fields'.intros)

lemma Fields'_eq_Fields:
  "Fields' P = Fields (Program P)"
by(auto simp add: fun_eq_iff intro: Fields'_into_Fields Fields_into_Fields')

code_pred
  (modes: i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> bool)
  Fields' .

definition fields' :: "'m cdecl list \<Rightarrow> cname \<Rightarrow> ((vname \<times> cname) \<times> (ty \<times> fmod)) list"
where "fields' P C = (if \<exists>FDTs. Fields' P C FDTs then THE FDTs. Fields' P C FDTs else [])"

lemma eval_Fields'_conv:
  "Predicate.eval (Fields'_i_i_o P C) = Fields' P C"
by(auto intro: Fields'_i_i_oI elim: Fields'_i_i_oE intro!: ext)

lemma fields'_code [code]:
  "fields' P C =
  (let FDTs = Fields'_i_i_o P C in if Predicate.holds (FDTs \<bind> (\<lambda>_. Predicate.single ())) then Predicate.the FDTs else [])"
by(auto simp add: fields'_def holds_eq Fields'_i_i_o_def intro: Fields'_i_i_oI Predicate.the_eqI[THEN sym])

lemma The_Fields [simp]:
  "P \<turnstile> C has_fields FDTs \<Longrightarrow> The (Fields P C) = FDTs"
by(auto dest: has_fields_fun)

lemma tabulate_sees_field_code [code]:
  "tabulate_sees_field P =
   Mapping.tabulate (map fst P) (\<lambda>C. Mapping.of_alist (map (\<lambda>((F, D), Tfm). (F, (D, Tfm))) (fields' P C)))"
apply(simp add: tabulate_sees_field_def tabulate_def is_class_def fields'_def Fields'_eq_Fields Mapping_inject)
apply(rule ext)
apply clarsimp
apply(rule conjI)
 apply(clarsimp simp add: o_def)
 apply(subst map_of_map2[unfolded split_def])
 apply simp
 apply transfer
 apply(rule conjI)
  apply clarsimp
  apply(rule ext)
  apply clarsimp
  apply(rule conjI)
   apply(clarsimp simp add: sees_field_def Fields'_eq_Fields)
   apply(drule (1) has_fields_fun, clarsimp)
  apply clarify
  apply(rule sym)
  apply(rule ccontr)
  apply(clarsimp simp add: sees_field_def Fields'_eq_Fields)
 apply clarsimp
 apply(rule ext)
 apply(clarsimp simp add: sees_field_def)
apply(clarsimp simp add: o_def)
apply(subst map_of_map2[simplified split_def])
apply(rule sym)
apply(clarsimp)
apply(rule ccontr)
apply simp
done

subsubsection \<open>@{term "Methods" }\<close>

text \<open>Same termination problem as for @{term Fields'}\<close>
inductive Methods' :: "'m cdecl list \<Rightarrow> cname \<Rightarrow> (mname \<times> (ty list \<times> ty \<times> 'm option) \<times> cname) list \<Rightarrow> bool"
  for P :: "'m cdecl list"
where
  "\<lbrakk> map_of P Object = Some(D,fs,ms); Mm = map (\<lambda>(M, rest). (M, (rest, Object))) ms \<rbrakk>
   \<Longrightarrow> Methods' P Object Mm"
| "\<lbrakk> map_of P C = Some(D,fs,ms); C \<noteq> Object; Methods' P D Mm;
     Mm' = map (\<lambda>(M, rest). (M, (rest, C))) ms @ Mm \<rbrakk>
   \<Longrightarrow> Methods' P C Mm'"

lemma Methods'_into_Methods:
  assumes "Methods' P C Mm"
  shows "Program P \<turnstile> C sees_methods (map_of Mm)"
using assms
apply induct
 apply(clarsimp simp add: o_def split_def)
 apply(rule sees_methods_Object)
  apply fastforce
 apply(rule ext)
 apply(subst map_of_map2[unfolded split_def])
 apply(simp add: o_def)

apply(rule sees_methods_rec)
   apply fastforce
  apply simp
 apply assumption
apply(clarsimp simp add: map_add_def map_of_map2)
done

lemma Methods_into_Methods':
  assumes "Program P \<turnstile> C sees_methods Mm"
  shows "\<exists>Mm'. Methods' P C Mm' \<and> Mm = map_of Mm'"
using assms
by induct(auto intro: Methods'.intros simp add: map_of_map2 map_add_def)

code_pred
  (modes: i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> bool)
  Methods'
.

definition methods' :: "'m cdecl list \<Rightarrow> cname \<Rightarrow> (mname \<times> (ty list \<times> ty \<times> 'm option) \<times> cname) list"
where "methods' P C = (if \<exists>Mm. Methods' P C Mm then THE Mm. Methods' P C Mm else [])"

lemma methods'_code [code]:
  "methods' P C =
  (let Mm = Methods'_i_i_o P C
   in if Predicate.holds (Mm \<bind> (\<lambda>_. Predicate.single ())) then Predicate.the Mm else [])"
unfolding methods'_def
by(auto simp add: holds_eq Methods'_i_i_o_def Predicate.the_def)

lemma Methods'_fun:
  assumes "Methods' P C Mm"
  shows "Methods' P C Mm' \<Longrightarrow> Mm = Mm'"
using assms
apply(induct arbitrary: Mm')
 apply(fastforce elim: Methods'.cases)
apply(rotate_tac -1)
apply(erule Methods'.cases)
 apply(fastforce)
apply clarify
apply(simp)
done

lemma The_Methods' [simp]: "Methods' P C Mm \<Longrightarrow> The (Methods' P C) = Mm"
by(auto dest: Methods'_fun)

lemma methods_def2 [simp]: "Methods' P C Mm \<Longrightarrow> methods' P C = Mm"
by(auto simp add: methods'_def)

lemma tabulate_Method_code [code]:
  "tabulate_Method P =
   Mapping.tabulate (map fst P) (\<lambda>C. Mapping.of_alist (map (\<lambda>(M, (rest, D)). (M, D, rest)) (methods' P C)))"
apply(simp add: tabulate_Method_def tabulate_def o_def lookup.rep_eq Mapping_inject)
apply(rule ext)
apply clarsimp
apply(rule conjI)
 apply clarify
 apply(rule sym)
 apply(subst map_of_map2[unfolded split_def])
 apply(simp add: is_class_def)
 apply transfer
 apply(rule ext)
 apply(simp add: map_of_map2)
 apply(rule conjI)
  apply(clarsimp simp add: map_of_map2 Method_def)
  apply(drule Methods_into_Methods')
  apply clarsimp
  apply(simp add: split_def)
  apply(subst map_of_map2[unfolded split_def])
  apply simp
 apply clarify
 apply(clarsimp simp add: methods'_def)
 apply(frule Methods'_into_Methods)
 apply(clarsimp simp add: Method_def)
 apply(simp add: split_def)
 apply(subst map_of_map2[unfolded split_def])
 apply(fastforce intro: ccontr)
apply clarify
apply(rule sym)
apply(simp add: map_of_eq_None_iff is_class_def)
apply(simp only: set_map[symmetric] map_map o_def fst_conv)
apply simp
done

text \<open>Merge modules TypeRel, Decl and TypeRelRefine to avoid cyclic modules\<close>

code_identifier
  code_module TypeRel \<rightharpoonup>
    (SML) TypeRel and (Haskell) TypeRel and (OCaml) TypeRel
| code_module TypeRelRefine \<rightharpoonup>
    (SML) TypeRel and (Haskell) TypeRel and (OCaml) TypeRel
| code_module Decl \<rightharpoonup>
    (SML) TypeRel and (Haskell) TypeRel and (OCaml) TypeRel

ML_val \<open>@{code Program}\<close>

end


(*  Title:       AWN_SOS.thy
    License:     BSD 2-Clause. See LICENSE.
    Author:      Timothy Bourke
*)

header "Semantics of the Algebra of Wireless Networks"

theory AWN_SOS
imports TransitionSystems AWN
begin

subsection "Table 1: Structural operational semantics for sequential process expressions "

inductive_set
  seqp_sos
  :: "('s, 'm, 'p, 'l) seqp_env \<Rightarrow> ('s \<times> ('s, 'm, 'p, 'l) seqp, 'm seq_action) transition set"
  for \<Gamma> :: "('s, 'm, 'p, 'l) seqp_env"
where
    broadcastT: "((\<xi>, {l}broadcast(s\<^sub>m\<^sub>s\<^sub>g).p),          broadcast (s\<^sub>m\<^sub>s\<^sub>g \<xi>),         (\<xi>, p)) \<in> seqp_sos \<Gamma>"
  | groupcastT: "((\<xi>, {l}groupcast(s\<^sub>i\<^sub>p\<^sub>s, s\<^sub>m\<^sub>s\<^sub>g).p),    groupcast (s\<^sub>i\<^sub>p\<^sub>s \<xi>) (s\<^sub>m\<^sub>s\<^sub>g \<xi>), (\<xi>, p)) \<in> seqp_sos \<Gamma>"
  | unicastT:   "((\<xi>, {l}unicast(s\<^sub>i\<^sub>p, s\<^sub>m\<^sub>s\<^sub>g).p \<triangleright> q),   unicast (s\<^sub>i\<^sub>p \<xi>) (s\<^sub>m\<^sub>s\<^sub>g \<xi>),    (\<xi>, p)) \<in> seqp_sos \<Gamma>"
  | notunicastT:"((\<xi>, {l}unicast(s\<^sub>i\<^sub>p, s\<^sub>m\<^sub>s\<^sub>g).p \<triangleright> q),    \<not>unicast (s\<^sub>i\<^sub>p \<xi>),          (\<xi>, q)) \<in> seqp_sos \<Gamma>"
  | sendT:      "((\<xi>, {l}send(s\<^sub>m\<^sub>s\<^sub>g).p),               send (s\<^sub>m\<^sub>s\<^sub>g \<xi>),              (\<xi>, p)) \<in> seqp_sos \<Gamma>"
  | deliverT:   "((\<xi>, {l}deliver(s\<^sub>d\<^sub>a\<^sub>t\<^sub>a).p),           deliver (s\<^sub>d\<^sub>a\<^sub>t\<^sub>a \<xi>),          (\<xi>, p)) \<in> seqp_sos \<Gamma>"
  | receiveT:   "((\<xi>, {l}receive(u\<^sub>m\<^sub>s\<^sub>g).p),            receive msg,       (u\<^sub>m\<^sub>s\<^sub>g msg \<xi>, p)) \<in> seqp_sos \<Gamma>"
  | assignT:    "((\<xi>, {l}\<lbrakk>u\<rbrakk> p),                      \<tau>,                        (u \<xi>, p)) \<in> seqp_sos \<Gamma>"

  | callT:      "\<lbrakk> ((\<xi>, \<Gamma> pn), a, (\<xi>', p')) \<in> seqp_sos \<Gamma> \<rbrakk> \<Longrightarrow>
                 ((\<xi>, call(pn)), a, (\<xi>', p')) \<in> seqp_sos \<Gamma>" (* TPB: quite different to Table 1 *)

  | choiceT1:   "((\<xi>, p), a, (\<xi>', p')) \<in> seqp_sos \<Gamma>  \<Longrightarrow> ((\<xi>, p \<oplus> q), a, (\<xi>', p')) \<in> seqp_sos \<Gamma>"
  | choiceT2:   "((\<xi>, q), a, (\<xi>', q')) \<in> seqp_sos \<Gamma>  \<Longrightarrow> ((\<xi>, p \<oplus> q), a, (\<xi>', q')) \<in> seqp_sos \<Gamma>"

  | guardT:     "\<xi>' \<in> g \<xi> \<Longrightarrow> ((\<xi>, {l}\<langle>g\<rangle> p), \<tau>, (\<xi>', p)) \<in> seqp_sos \<Gamma>"

inductive_cases
      seqp_callTE [elim]:      "((\<xi>, call(pn)), a, (\<xi>', q)) \<in> seqp_sos \<Gamma>"
  and seqp_choiceTE [elim]:    "((\<xi>, p1 \<oplus> p2), a, (\<xi>', q)) \<in> seqp_sos \<Gamma>"

lemma seqp_broadcastTE [elim]:
  "\<lbrakk>((\<xi>, {l}broadcast(s\<^sub>m\<^sub>s\<^sub>g). p), a, (\<xi>', q)) \<in> seqp_sos \<Gamma>;
    \<lbrakk>a = broadcast (s\<^sub>m\<^sub>s\<^sub>g \<xi>); \<xi>' = \<xi>; q = p\<rbrakk> \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
  by (ind_cases "((\<xi>, {l}broadcast(s\<^sub>m\<^sub>s\<^sub>g). p), a, (\<xi>', q)) \<in> seqp_sos \<Gamma>") simp

lemma seqp_groupcastTE [elim]:
  "\<lbrakk>((\<xi>, {l}groupcast(s\<^sub>i\<^sub>p\<^sub>s, s\<^sub>m\<^sub>s\<^sub>g). p), a, (\<xi>', q)) \<in> seqp_sos \<Gamma>;
    \<lbrakk>a = groupcast (s\<^sub>i\<^sub>p\<^sub>s \<xi>) (s\<^sub>m\<^sub>s\<^sub>g \<xi>); \<xi>' = \<xi>; q = p\<rbrakk> \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
  by (ind_cases "((\<xi>, {l}groupcast(s\<^sub>i\<^sub>p\<^sub>s, s\<^sub>m\<^sub>s\<^sub>g). p), a, (\<xi>', q)) \<in> seqp_sos \<Gamma>") simp

lemma seqp_unicastTE [elim]:
  "\<lbrakk>((\<xi>, {l}unicast(s\<^sub>i\<^sub>p, s\<^sub>m\<^sub>s\<^sub>g). p \<triangleright> q), a, (\<xi>', r)) \<in> seqp_sos \<Gamma>;
    \<lbrakk>a = unicast (s\<^sub>i\<^sub>p \<xi>) (s\<^sub>m\<^sub>s\<^sub>g \<xi>); \<xi>' = \<xi>; r = p\<rbrakk> \<Longrightarrow> P;
    \<lbrakk>a = \<not>unicast (s\<^sub>i\<^sub>p \<xi>); \<xi>' = \<xi>; r = q\<rbrakk> \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
  by (ind_cases "((\<xi>, {l}unicast(s\<^sub>i\<^sub>p, s\<^sub>m\<^sub>s\<^sub>g). p \<triangleright> q), a, (\<xi>', r)) \<in> seqp_sos \<Gamma>") simp_all

lemma seqp_sendTE [elim]:
  "\<lbrakk>((\<xi>, {l}send(s\<^sub>m\<^sub>s\<^sub>g). p), a, (\<xi>', q)) \<in> seqp_sos \<Gamma>;
    \<lbrakk>a = send (s\<^sub>m\<^sub>s\<^sub>g \<xi>); \<xi>' = \<xi>; q = p\<rbrakk> \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
  by (ind_cases "((\<xi>, {l}send(s\<^sub>m\<^sub>s\<^sub>g). p), a, (\<xi>', q)) \<in> seqp_sos \<Gamma>") simp

lemma seqp_deliverTE [elim]:
  "\<lbrakk>((\<xi>, {l}deliver(s\<^sub>d\<^sub>a\<^sub>t\<^sub>a). p), a, (\<xi>', q)) \<in> seqp_sos \<Gamma>;
    \<lbrakk>a = deliver (s\<^sub>d\<^sub>a\<^sub>t\<^sub>a \<xi>); \<xi>' = \<xi>; q = p\<rbrakk> \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
  by (ind_cases "((\<xi>, {l}deliver(s\<^sub>d\<^sub>a\<^sub>t\<^sub>a). p), a, (\<xi>', q)) \<in> seqp_sos \<Gamma>") simp

lemma seqp_receiveTE [elim]:
  "\<lbrakk>((\<xi>, {l}receive(u\<^sub>m\<^sub>s\<^sub>g). p), a, (\<xi>', q)) \<in> seqp_sos \<Gamma>;
    \<And>msg. \<lbrakk>a = receive msg; \<xi>' = u\<^sub>m\<^sub>s\<^sub>g msg \<xi>; q = p\<rbrakk> \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
  by (ind_cases "((\<xi>, {l}receive(u\<^sub>m\<^sub>s\<^sub>g). p), a, (\<xi>', q)) \<in> seqp_sos \<Gamma>") simp

lemma seqp_assignTE [elim]:
  "\<lbrakk>((\<xi>, {l}\<lbrakk>u\<rbrakk> p), a, (\<xi>', q)) \<in> seqp_sos \<Gamma>; \<lbrakk>a = \<tau>; \<xi>' = u \<xi>; q = p\<rbrakk> \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
  by (ind_cases "((\<xi>, {l}\<lbrakk>u\<rbrakk> p), a, (\<xi>', q)) \<in> seqp_sos \<Gamma>") simp

lemmas seqpTEs =
  seqp_broadcastTE
  seqp_groupcastTE
  seqp_unicastTE
  seqp_sendTE
  seqp_deliverTE
  seqp_receiveTE
  seqp_assignTE
  seqp_callTE
  seqp_choiceTE
  seqp_guardTE

declare seqp_sos.intros [intro]

subsection "Table 2: Structural operational semantics for parallel process expressions "

inductive_set
  parp_sos :: "('s1, 'm seq_action) transition set
                    \<Rightarrow> ('s2, 'm seq_action) transition set
                    \<Rightarrow> ('s1 \<times> 's2, 'm seq_action) transition set"
  for S :: "('s1, 'm seq_action) transition set"
  and T :: "('s2, 'm seq_action) transition set"
where
    parleft:  "\<lbrakk> (s, a, s') \<in> S; \<And>m. a \<noteq> receive m \<rbrakk> \<Longrightarrow> ((s, t), a, (s', t)) \<in> parp_sos S T"
  | parright: "\<lbrakk> (t, a, t') \<in> T; \<And>m. a \<noteq> send m \<rbrakk> \<Longrightarrow> ((s, t), a, (s, t')) \<in> parp_sos S T"
  | parboth:  "\<lbrakk> (s, receive m, s') \<in> S; (t, send m, t') \<in> T \<rbrakk>
               \<Longrightarrow>((s, t), \<tau>, (s', t')) \<in> parp_sos S T"

lemma par_broadcastTE [elim]:
  "\<lbrakk>((s, t), broadcast m, (s', t')) \<in> parp_sos S T;
    \<lbrakk>(s, broadcast m, s') \<in> S; t' = t\<rbrakk> \<Longrightarrow> P;
    \<lbrakk>(t, broadcast m, t') \<in> T; s' = s\<rbrakk> \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
  by (ind_cases "((s, t), broadcast m, (s', t')) \<in> parp_sos S T") simp_all

lemma par_groupcastTE [elim]:
  "\<lbrakk>((s, t), groupcast ips m, (s', t')) \<in> parp_sos S T;
    \<lbrakk>(s, groupcast ips m, s') \<in> S; t' = t\<rbrakk> \<Longrightarrow> P;
    \<lbrakk>(t, groupcast ips m, t') \<in> T; s' = s\<rbrakk> \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
  by (ind_cases "((s, t), groupcast ips m, (s', t')) \<in> parp_sos S T") simp_all

lemma par_unicastTE [elim]:
  "\<lbrakk>((s, t), unicast i m, (s', t')) \<in> parp_sos S T;
    \<lbrakk>(s, unicast i m, s') \<in> S; t' = t\<rbrakk> \<Longrightarrow> P;
    \<lbrakk>(t, unicast i m, t') \<in> T; s' = s\<rbrakk> \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
  by (ind_cases "((s, t), unicast i m, (s', t')) \<in> parp_sos S T") simp_all

lemma par_notunicastTE [elim]:
  "\<lbrakk>((s, t), notunicast i, (s', t')) \<in> parp_sos S T;
    \<lbrakk>(s, notunicast i, s') \<in> S; t' = t\<rbrakk> \<Longrightarrow> P;
    \<lbrakk>(t, notunicast i, t') \<in> T; s' = s\<rbrakk> \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
  by (ind_cases "((s, t), notunicast i, (s', t')) \<in> parp_sos S T") simp_all

lemma par_sendTE [elim]:
  "\<lbrakk>((s, t), send m, (s', t')) \<in> parp_sos S T;
    \<lbrakk>(s, send m, s') \<in> S; t' = t\<rbrakk> \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
  by (ind_cases "((s, t), send m, (s', t')) \<in> parp_sos S T") auto

lemma par_deliverTE [elim]:
  "\<lbrakk>((s, t), deliver d, (s', t')) \<in> parp_sos S T;
    \<lbrakk>(s, deliver d, s') \<in> S; t' = t\<rbrakk> \<Longrightarrow> P;
    \<lbrakk>(t, deliver d, t') \<in> T; s' = s\<rbrakk> \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
  by (ind_cases "((s, t), deliver d, (s', t')) \<in> parp_sos S T") simp_all

lemma par_receiveTE [elim]:
  "\<lbrakk>((s, t), receive m, (s', t')) \<in> parp_sos S T;
    \<lbrakk>(t, receive m, t') \<in> T; s' = s\<rbrakk> \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
  by (ind_cases "((s, t), receive m, (s', t')) \<in> parp_sos S T") auto

inductive_cases par_tauTE: "((s, t), \<tau>, (s', t')) \<in> parp_sos S T"

lemmas parpTEs =
  par_broadcastTE
  par_groupcastTE
  par_unicastTE
  par_notunicastTE
  par_sendTE
  par_deliverTE
  par_receiveTE

lemma parp_sos_cases [elim]:
  assumes "((s, t), a, (s', t')) \<in> parp_sos S T"
      and "\<lbrakk> (s, a, s') \<in> S; \<And>m. a \<noteq> receive m; t' = t \<rbrakk> \<Longrightarrow> P"
      and "\<lbrakk> (t, a, t') \<in> T; \<And>m. a \<noteq> send m; s' = s \<rbrakk> \<Longrightarrow> P"
      and "\<And>m. \<lbrakk> (s, receive m, s') \<in> S; (t, send m, t') \<in> T \<rbrakk> \<Longrightarrow> P"
    shows "P"
  using assms by cases auto

definition
  par_comp :: "('s1, 'm seq_action) automaton
              \<Rightarrow> ('s2, 'm seq_action) automaton
              \<Rightarrow> ('s1 \<times> 's2, 'm seq_action) automaton"
  ("(_ \<langle>\<langle> _)" [102, 103] 102)
where
  "s \<langle>\<langle> t \<equiv> \<lparr> init = init s \<times> init t, trans = parp_sos (trans s) (trans t) \<rparr>"

lemma trans_par_comp [simp]:
  "trans (s \<langle>\<langle> t) = parp_sos (trans s) (trans t)"
  unfolding par_comp_def by simp

lemma init_par_comp [simp]:
  "init (s \<langle>\<langle> t) = init s \<times> init t"
  unfolding par_comp_def by simp

subsection "Table 3: Structural operational semantics for node expressions "

inductive_set
  node_sos :: "('s, 'm seq_action) transition set \<Rightarrow> ('s net_state, 'm node_action) transition set"
  for S :: "('s, 'm seq_action) transition set"
where
    node_bcast:
    "(s, broadcast m, s') \<in> S \<Longrightarrow> (NodeS i s R, R:*cast(m), NodeS i s' R) \<in> node_sos S"
  | node_gcast:
    "(s, groupcast D m, s') \<in> S \<Longrightarrow> (NodeS i s R, (R\<inter>D):*cast(m), NodeS i s' R) \<in> node_sos S"
  | node_ucast:
    "\<lbrakk> (s, unicast d m, s') \<in> S; d\<in>R \<rbrakk> \<Longrightarrow> (NodeS i s R, {d}:*cast(m), NodeS i s' R) \<in> node_sos S"
  | node_notucast:
    "\<lbrakk> (s, \<not>unicast d, s') \<in> S; d\<notin>R \<rbrakk> \<Longrightarrow> (NodeS i s R, \<tau>, NodeS i s' R) \<in> node_sos S"
  | node_deliver:
    "(s, deliver d, s') \<in> S \<Longrightarrow> (NodeS i s R, i:deliver(d), NodeS i s' R) \<in> node_sos S"
  | node_receive:
    "(s, receive m, s') \<in> S \<Longrightarrow> (NodeS i s R, {i}\<not>{}:arrive(m), NodeS i s' R) \<in> node_sos S"
  | node_tau:
    "(s, \<tau>, s') \<in> S         \<Longrightarrow> (NodeS i s R, \<tau>, NodeS i s' R) \<in> node_sos S"
  | node_arrive:
    "(NodeS i s R, {}\<not>{i}:arrive(m),  NodeS i s R) \<in> node_sos S"
  | node_connect1:
    "(NodeS i s R, connect(i, i'),    NodeS i s (R \<union> {i'})) \<in> node_sos S"
  | node_connect2:
    "(NodeS i s R, connect(i', i),    NodeS i s (R \<union> {i'})) \<in> node_sos S"
  | node_disconnect1:
    "(NodeS i s R, disconnect(i, i'), NodeS i s (R - {i'})) \<in> node_sos S"
  | node_disconnect2:
    "(NodeS i s R, disconnect(i', i), NodeS i s (R - {i'})) \<in> node_sos S"
  | node_connect_other:
    "\<lbrakk> i \<noteq> i'; i \<noteq> i'' \<rbrakk> \<Longrightarrow> (NodeS i s R, connect(i', i''), NodeS i s R) \<in> node_sos S"
  | node_disconnect_other:
    "\<lbrakk> i \<noteq> i'; i \<noteq> i'' \<rbrakk> \<Longrightarrow> (NodeS i s R, disconnect(i', i''), NodeS i s R) \<in> node_sos S"

inductive_cases node_arriveTE:  "(NodeS i s R, ii\<not>ni:arrive(m), NodeS i s' R) \<in> node_sos S"
            and node_arriveTE': "(NodeS i s R, H\<not>K:arrive(m), s') \<in> node_sos S"
            and node_castTE:    "(NodeS i s R, RM:*cast(m), NodeS i s' R') \<in> node_sos S"
            and node_castTE':   "(NodeS i s R, RM:*cast(m), s') \<in> node_sos S"
            and node_deliverTE: "(NodeS i s R, i:deliver(d), NodeS i s' R) \<in> node_sos S"
            and node_deliverTE': "(s, i:deliver(d), s') \<in> node_sos S"
            and node_deliverTE'': "(NodeS ii s R, i:deliver(d), s') \<in> node_sos S"
            and node_tauTE:     "(NodeS i s R, \<tau>, NodeS i s' R) \<in> node_sos S"
            and node_tauTE':    "(NodeS i s R, \<tau>, s') \<in> node_sos S"
            and node_connectTE: "(NodeS ii s R, connect(i, i'), NodeS ii s' R') \<in> node_sos S"
            and node_connectTE': "(NodeS ii s R, connect(i, i'), s') \<in> node_sos S"
            and node_disconnectTE: "(NodeS ii s R, disconnect(i, i'), NodeS ii s' R') \<in> node_sos S"
            and node_disconnectTE': "(NodeS ii s R, disconnect(i, i'), s') \<in> node_sos S"

lemma node_sos_never_newpkt [simp]:
  assumes "(s, a, s') \<in> node_sos S"
    shows "a \<noteq> i:newpkt(d, di)"
  using assms by cases auto

lemma arrives_or_not:
  assumes "(NodeS i s R, ii\<not>ni:arrive(m), NodeS i' s' R') \<in> node_sos S"
    shows "(ii = {i} \<and> ni = {}) \<or> (ii = {} \<and> ni = {i})"
  using assms by rule simp_all

definition
  node_comp :: "ip \<Rightarrow> ('s, 'm seq_action) automaton \<Rightarrow> ip set
                   \<Rightarrow> ('s net_state, 'm node_action) automaton"
    ("(\<langle>_ : (_) : _\<rangle>)" [0, 0, 0] 104)
where
  "\<langle>i : np : R\<^sub>i\<rangle> \<equiv> \<lparr> init = {NodeS i s R\<^sub>i|s. s \<in> init np}, trans = node_sos (trans np) \<rparr>"

lemma trans_node_comp:
  "trans (\<langle>i : np : R\<^sub>i\<rangle>) = node_sos (trans np)"
  unfolding node_comp_def by simp

lemma init_node_comp:
  "init (\<langle>i : np : R\<^sub>i\<rangle>) = {NodeS i s R\<^sub>i|s. s \<in> init np}"
  unfolding node_comp_def by simp

lemmas node_comps = trans_node_comp init_node_comp

lemma trans_par_node_comp [simp]:
  "trans (\<langle>i : s \<langle>\<langle> t : R\<rangle>) = node_sos (parp_sos (trans s) (trans t))"
  unfolding node_comp_def by simp

lemma snd_par_node_comp [simp]:
  "init (\<langle>i : s \<langle>\<langle> t : R\<rangle>) = {NodeS i st R|st. st \<in> init s \<times> init t}"
  unfolding node_comp_def by simp

lemma node_sos_dest_is_net_state:
  assumes "(s, a, s') \<in> node_sos S"
    shows "\<exists>i' P' R'. s' = NodeS i' P' R'"
  using assms by induct auto

lemma node_sos_dest:
  assumes "(NodeS i p R, a, s') \<in> node_sos S"
    shows "\<exists>P' R'. s' = NodeS i P' R'"
  using assms assms [THEN node_sos_dest_is_net_state]
  by - (erule node_sos.cases, auto)

lemma node_sos_states [elim]:
  assumes "(ns, a, ns') \<in> node_sos S"
  obtains i s R s' R' where "ns  = NodeS i s  R"
                        and "ns' = NodeS i s' R'"
  proof -
    assume [intro!]: "\<And>i s R s' R'. ns = NodeS i s R \<Longrightarrow> ns' = NodeS i s' R' \<Longrightarrow> thesis"
    from assms(1) obtain i s R where "ns = NodeS i s R"
      by (cases ns) auto
    moreover with assms(1) obtain s' R' where "ns' = NodeS i s' R'"
      by (metis node_sos_dest)
    ultimately show thesis ..
  qed

lemma node_sos_cases [elim]:
  "(NodeS i p R, a, NodeS i p' R') \<in> node_sos S \<Longrightarrow>
  (\<And>m .       \<lbrakk> a = R:*cast(m);          R' = R; (p, broadcast m, p') \<in> S \<rbrakk> \<Longrightarrow> P) \<Longrightarrow>
  (\<And>m D.      \<lbrakk> a = (R \<inter> D):*cast(m);    R' = R; (p, groupcast D m, p') \<in> S \<rbrakk> \<Longrightarrow> P) \<Longrightarrow>
  (\<And>d m.      \<lbrakk> a = {d}:*cast(m);        R' = R; (p, unicast d m, p') \<in> S; d \<in> R \<rbrakk> \<Longrightarrow> P) \<Longrightarrow>
  (\<And>d.        \<lbrakk> a = \<tau>;                   R' = R; (p, \<not>unicast d, p') \<in> S; d \<notin> R \<rbrakk> \<Longrightarrow> P) \<Longrightarrow>
  (\<And>d.        \<lbrakk> a = i:deliver(d);        R' = R; (p, deliver d, p') \<in> S \<rbrakk> \<Longrightarrow> P) \<Longrightarrow>
  (\<And>m.        \<lbrakk> a = {i}\<not>{}:arrive(m);    R' = R; (p, receive m, p') \<in> S \<rbrakk> \<Longrightarrow> P) \<Longrightarrow>
  (            \<lbrakk> a = \<tau>;                   R' = R; (p, \<tau>, p') \<in> S \<rbrakk> \<Longrightarrow> P) \<Longrightarrow>
  (\<And>m.        \<lbrakk> a = {}\<not>{i}:arrive(m);    R' = R; p = p' \<rbrakk> \<Longrightarrow> P) \<Longrightarrow>
  (\<And>i i'.     \<lbrakk> a = connect(i, i');      R' = R \<union> {i'}; p = p' \<rbrakk> \<Longrightarrow> P) \<Longrightarrow>
  (\<And>i i'.     \<lbrakk> a = connect(i', i);      R' = R \<union> {i'}; p = p' \<rbrakk> \<Longrightarrow> P) \<Longrightarrow>
  (\<And>i i'.     \<lbrakk> a = disconnect(i, i');   R' = R - {i'}; p = p' \<rbrakk> \<Longrightarrow> P) \<Longrightarrow>
  (\<And>i i'.     \<lbrakk> a = disconnect(i', i);   R' = R - {i'}; p = p' \<rbrakk> \<Longrightarrow> P) \<Longrightarrow>
  (\<And>i i' i''. \<lbrakk> a = connect(i', i'');    R' = R; p = p'; i \<noteq> i'; i \<noteq> i'' \<rbrakk> \<Longrightarrow> P) \<Longrightarrow>
  (\<And>i i' i''. \<lbrakk> a = disconnect(i', i''); R' = R; p = p'; i \<noteq> i'; i \<noteq> i'' \<rbrakk> \<Longrightarrow> P) \<Longrightarrow>
  P"
  by (erule node_sos.cases) simp_all

subsection "Table 4: Structural operational semantics for partial network expressions "

inductive_set
  pnet_sos :: "('s net_state, 'm node_action) transition set
                    \<Rightarrow> ('s net_state, 'm node_action) transition set
                    \<Rightarrow> ('s net_state, 'm node_action) transition set"
  for S :: "('s net_state, 'm node_action) transition set"
  and T :: "('s net_state, 'm node_action) transition set"
where
    pnet_cast1: "\<lbrakk> (s, R:*cast(m), s') \<in> S; (t, H\<not>K:arrive(m), t') \<in> T; H \<subseteq> R; K \<inter> R = {} \<rbrakk>
      \<Longrightarrow> (SubnetS s t, R:*cast(m), SubnetS s' t') \<in> pnet_sos S T"

  | pnet_cast2: "\<lbrakk> (s, H\<not>K:arrive(m), s') \<in> S; (t, R:*cast(m), t') \<in> T;  H \<subseteq> R; K \<inter> R = {} \<rbrakk>
      \<Longrightarrow> (SubnetS s t, R:*cast(m), SubnetS s' t') \<in> pnet_sos S T"

  | pnet_arrive: "\<lbrakk> (s, H\<not>K:arrive(m), s') \<in> S; (t, H'\<not>K':arrive(m), t') \<in> T \<rbrakk>
      \<Longrightarrow> (SubnetS s t,  (H \<union> H')\<not>(K \<union> K'):arrive(m), SubnetS s' t') \<in> pnet_sos S T"

  | pnet_deliver1: "(s, i:deliver(d), s') \<in> S
      \<Longrightarrow> (SubnetS s t, i:deliver(d), SubnetS s' t) \<in> pnet_sos S T"
  | pnet_deliver2: "\<lbrakk> (t, i:deliver(d), t') \<in> T \<rbrakk>
      \<Longrightarrow> (SubnetS s t, i:deliver(d), SubnetS s t') \<in> pnet_sos S T"

  | pnet_tau1: "(s, \<tau>, s') \<in> S \<Longrightarrow> (SubnetS s t, \<tau>, SubnetS s' t) \<in> pnet_sos S T"
  | pnet_tau2: "(t, \<tau>, t') \<in> T \<Longrightarrow> (SubnetS s t, \<tau>, SubnetS s t') \<in> pnet_sos S T"

  | pnet_connect: "\<lbrakk> (s, connect(i, i'), s') \<in> S; (t, connect(i, i'), t') \<in> T \<rbrakk>
      \<Longrightarrow> (SubnetS s t, connect(i, i'), SubnetS s' t') \<in> pnet_sos S T"

  | pnet_disconnect: "\<lbrakk> (s, disconnect(i, i'), s') \<in> S; (t, disconnect(i, i'), t') \<in> T \<rbrakk>
      \<Longrightarrow> (SubnetS s t, disconnect(i, i'), SubnetS s' t') \<in> pnet_sos S T"

inductive_cases partial_castTE [elim]:       "(s, R:*cast(m), s') \<in> pnet_sos S T"
            and partial_arriveTE [elim]:     "(s, H\<not>K:arrive(m), s') \<in> pnet_sos S T"
            and partial_deliverTE [elim]:    "(s, i:deliver(d), s') \<in> pnet_sos S T"
            and partial_tauTE [elim]:        "(s, \<tau>, s') \<in> pnet_sos S T"
            and partial_connectTE [elim]:    "(s, connect(i, i'), s') \<in> pnet_sos S T"
            and partial_disconnectTE [elim]: "(s, disconnect(i, i'), s') \<in> pnet_sos S T"

lemma pnet_sos_never_newpkt:
  assumes "(st, a, st') \<in> pnet_sos S T"
      and "\<And>i d di a s s'. (s, a, s') \<in> S \<Longrightarrow> a \<noteq> i:newpkt(d, di)"
      and "\<And>i d di a t t'. (t, a, t') \<in> T \<Longrightarrow> a \<noteq> i:newpkt(d, di)"
    shows "a \<noteq> i:newpkt(d, di)"
  using assms(1) by cases (auto dest!: assms(2-3))

fun pnet :: "(ip \<Rightarrow> ('s, 'm seq_action) automaton)
              \<Rightarrow> net_tree \<Rightarrow> ('s net_state, 'm node_action) automaton"
where
    "pnet np (\<langle>i; R\<^sub>i\<rangle>)  =  \<langle>i : np i : R\<^sub>i\<rangle>"
  | "pnet np (p\<^sub>1 \<parallel> p\<^sub>2) = \<lparr> init = {SubnetS s\<^sub>1 s\<^sub>2 |s\<^sub>1 s\<^sub>2. s\<^sub>1 \<in> init (pnet np p\<^sub>1)
                                                      \<and> s\<^sub>2 \<in> init (pnet np p\<^sub>2)},
                           trans = pnet_sos (trans (pnet np p\<^sub>1)) (trans (pnet np p\<^sub>2)) \<rparr>"

lemma pnet_node_init [elim, simp]:
  assumes "s \<in> init (pnet np \<langle>i; R\<rangle>)"
    shows "s \<in> { NodeS i s R |s. s \<in> init (np i)}"
  using assms by (simp add: node_comp_def)

lemma pnet_node_init' [elim]:
 assumes "s \<in> init (pnet np \<langle>i; R\<rangle>)"
 obtains ns where "s = NodeS i ns R"
             and "ns \<in> init (np i)"
   using assms by (auto simp add: node_comp_def)

lemma pnet_node_trans [elim, simp]:
  assumes "(s, a, s') \<in> trans (pnet np \<langle>i; R\<rangle>)"
    shows "(s, a, s') \<in> node_sos (trans (np i))"
  using assms by (simp add: trans_node_comp)

lemma pnet_never_newpkt':
  assumes "(s, a, s') \<in> trans (pnet np n)"
    shows "\<forall>i d di. a \<noteq> i:newpkt(d, di)"
  using assms proof (induction n arbitrary: s a s')
    fix n1 n2 s a s'
    assume IH1: "\<And>s a s'. (s, a, s') \<in> trans (pnet np n1) \<Longrightarrow> \<forall>i d di. a \<noteq> i:newpkt(d, di)"
       and IH2: "\<And>s a s'. (s, a, s') \<in> trans (pnet np n2) \<Longrightarrow> \<forall>i d di. a \<noteq> i:newpkt(d, di)"
       and "(s, a, s') \<in> trans (pnet np (n1 \<parallel> n2))"
    show "\<forall>i d di. a \<noteq> i:newpkt(d, di)"
    proof (intro allI)
      fix i d di
      from \<open>(s, a, s') \<in> trans (pnet np (n1 \<parallel> n2))\<close>
        have "(s, a, s') \<in> pnet_sos (trans (pnet np n1)) (trans (pnet np n2))"
          by simp
      thus "a \<noteq> i:newpkt(d, di)"
        by (rule pnet_sos_never_newpkt) (auto dest!: IH1 IH2)
    qed
  qed (simp add: node_comps)

lemma pnet_never_newpkt:
  assumes "(s, a, s') \<in> trans (pnet np n)"
    shows "a \<noteq> i:newpkt(d, di)"
  proof -
    from assms have "\<forall>i d di. a \<noteq> i:newpkt(d, di)"
      by (rule pnet_never_newpkt')
    thus ?thesis by clarsimp
  qed

subsection "Table 5: Structural operational semantics for complete network expressions "

inductive_set
  cnet_sos :: "('s, ('m::msg) node_action) transition set
                    \<Rightarrow> ('s, 'm node_action) transition set"
  for S :: "('s, 'm node_action) transition set"
where
    cnet_connect: "(s, connect(i, i'), s') \<in> S  \<Longrightarrow> (s, connect(i, i'), s') \<in> cnet_sos S"
  | cnet_disconnect: "(s, disconnect(i, i'), s') \<in> S  \<Longrightarrow> (s, disconnect(i, i'), s') \<in> cnet_sos S"
  | cnet_cast: "(s, R:*cast(m), s') \<in> S  \<Longrightarrow> (s, \<tau>, s') \<in> cnet_sos S"
  | cnet_tau: "(s, \<tau>, s') \<in> S  \<Longrightarrow> (s, \<tau>, s') \<in> cnet_sos S"
  | cnet_deliver: "(s, i:deliver(d), s') \<in> S  \<Longrightarrow> (s, i:deliver(d), s') \<in> cnet_sos S"
  | cnet_newpkt: "(s, {i}\<not>K:arrive(newpkt(d, di)), s') \<in> S  \<Longrightarrow> (s, i:newpkt(d, di), s') \<in> cnet_sos S"

inductive_cases connect_completeTE: "(s, connect(i, i'), s') \<in> cnet_sos S"
            and disconnect_completeTE: "(s, disconnect(i, i'), s') \<in> cnet_sos S"
            and tau_completeTE: "(s, \<tau>, s') \<in> cnet_sos S"
            and deliver_completeTE: "(s, i:deliver(d), s') \<in> cnet_sos S"
            and newpkt_completeTE: "(s, i:newpkt(d, di), s') \<in> cnet_sos S"

lemmas completeTEs = connect_completeTE
                     disconnect_completeTE
                     tau_completeTE
                     deliver_completeTE
                     newpkt_completeTE

lemma complete_no_cast [simp]:
  "(s, R:*cast(m), s') \<notin> cnet_sos T"
  proof
    assume "(s, R:*cast(m), s') \<in> cnet_sos T"
    hence "R:*cast(m) \<noteq> R:*cast(m)"
     by (rule cnet_sos.cases) auto
    thus False by simp
  qed

lemma complete_no_arrive [simp]:
  "(s, ii\<not>ni:arrive(m), s') \<notin> cnet_sos T"
  proof
    assume "(s, ii\<not>ni:arrive(m), s') \<in> cnet_sos T"
    hence "ii\<not>ni:arrive(m) \<noteq> ii\<not>ni:arrive(m)"
     by (rule cnet_sos.cases) auto
    thus False by simp
  qed

abbreviation
  closed :: "('s net_state, ('m::msg) node_action) automaton \<Rightarrow> ('s net_state, 'm node_action) automaton"
where
  "closed \<equiv> (\<lambda>A. A \<lparr> trans := cnet_sos (trans A) \<rparr>)"

end