I am trying to extend the Nagel-Schreckenberg model for traffic flow to include two lanes of traffic.
I have a function that generates information about a random initial road configuration. A road in this case is thought of as two lines of cells side-by-side (representing two lanes) and each cell can be occupied by a car with an integer velocity less than some specified maximum velocity. The road is closed, ie once a car passes the last cell in a lane, it returns to the starting cell in that lane. The model is iterative. At each iteration, each car first decides whether to change lane (depending on lane-changing rules), and then the situation is updated according to the same rules as for the single-lane situation. It is specifically the lane-change step im struggling with.
The number of cars n, the length of the road l and the maximum velocity vmax are arguments for my road-generating function:
twoLanes[n_, l_, vmax_] := Module[{a = {}, b, lengtha},
Do[AppendTo[a, {b = RandomInteger[], If[b > 0, RandomInteger[{0, vmax}], 0],
If[b > 0, i, 0], i, RandomInteger[{1, 2}]}];
If[Length[Cases[Transpose[a][[1]], 1]] == n, Break[]], {i, l}];
lengtha = Length[a];
Do[AppendTo[a, {0, 0, 0, i}], {i, lengtha + 1, l}];
Map[Rest, Cases[a, {x_ /; x == 1, _, _, _, _}]]]
For example
twoLanes[10, 500, 5]
gives the list
{{2, 2, 2, 1}, {5, 4, 4, 2}, {4, 5, 5, 2}, {0, 7, 7, 2}, {5, 11, 11,
1}, {0, 13, 13, 2}, {2, 15, 15, 1}, {2, 16, 16, 1}, {0, 18, 18,
2}, {5, 19, 19, 2}, {0, 20, 20, 2}, {5, 21, 21, 2}, {1, 22, 22,
2}, {3, 24, 24, 2}, {4, 25, 25, 1}, {1, 26, 26, 2}, {2, 28, 28,
2}, {5, 31, 31, 1}, {5, 32, 32, 2}, {2, 38, 38, 1}}
each element in this list is of the form {car velocity, car label, car position along road, lane number}. The label is for later use to track a specific car's journey.
How would I implement the following lane-changing procedure (here "gap" refers to the number of cells between two cars):
- the gap ahead in the same lane is less than v+1,
- the gap ahead in the other lane is greater than v+1,
- the gap behind in the other lane is greater than vmax.
I have tried a number of different ways of representing the two lane scenario, and my twoLanes function above is my latest attempt.
One lane code
One-lane road generating function:
ll3[n_, l_, vmax_] := Module[{a = {}, b, lengtha},
Do[AppendTo[
a, {b = RandomInteger[], If[b > 0, RandomInteger[{0, vmax}], 0],
If[b > 0, i, 0], i}];
If[Length[Cases[Transpose[a][[1]], 1]] == n, Break[]], {i, l}];
lengtha = Length[a];
Do[AppendTo[a, {0, 0, 0, i}], {i, lengtha + 1, l}];
Map[Rest, Cases[a, {x_ /; x == 1, _, _, _}]]]
one-lane update rules:
- If the velocity v of the car is lower than vmax , and the distance to the next car ahead is larger than v + 1, the speed is increased by one.
- If a driver at site i sees the next vehicle at site i+j, with j <= v, he reduces speed to j −1.
- The velocity of each vehicle (if greater than zero) is decreased by one with probability p (‘dawdling’).
- Each vehicle is advanced by v sites.
One-lane update functions :
update2[lane_, length_, vmax_, p_] := Module[{newlane},
newlane = lane;
Do[If[(newlane[[i, 1]] <
vmax) && (newlane[[i + 1, 3]] -
newlane[[i, 3]]) > (newlane[[i, 1]] + 1),
newlane[[i, 1]] = newlane[[i, 1]] + 1,
newlane[[i, 1]] = newlane[[i, 1]]], {i, 1, Length[newlane] - 1}];
If[(newlane[[-1, 1]] <
vmax) && (newlane[[1, 3]] - newlane[[-1, 3]] +
length) > (newlane[[-1, 1]] + 1),
newlane[[-1, 1]] = newlane[[-1, 1]] + 1,
newlane[[-1, 1]] = newlane[[-1, 1]]];
Do[
If[(newlane[[i + 1, 3]] - newlane[[i, 3]]) <= newlane[[i, 1]],
newlane[[i, 1]] = (newlane[[i + 1, 3]] - newlane[[i, 3]]) - 1,
newlane[[i, 1]] = newlane[[i, 1]]], {i, 1, Length[newlane] - 1}];
If[(newlane[[1, 3]] - newlane[[-1, 3]] + length) < newlane[[-1, 1]],
newlane[[-1,
1]] = (newlane[[1, 3]] - newlane[[-1, 3]] + length) - 1,
newlane[[-1, 1]] = newlane[[-1, 1]]];
Do[
If[newlane[[i, 1]] > 0 && RandomReal[] < p,
newlane[[i, 1]] = newlane[[i, 1]] - 1,
newlane[[i, 1]] = newlane[[i, 1]]], {i, 1, Length[newlane] - 1}];
If[newlane[[-1, 1]] > 0 && RandomReal[] < p,
newlane[[-1, 1]] = newlane[[-1, 1]] - 1,
newlane[[-1, 1]] = newlane[[-1, 1]]];
Do[
If[(newlane[[i, 3]] + newlane[[i, 1]]) <= length,
newlane[[i, 3]] = newlane[[i, 3]] + newlane[[i, 1]],
newlane[[i, 3]] = newlane[[i, 3]] + newlane[[i, 1]] - length], {i,
1, Length[lane]}];
Sort[newlane, #1[[3]] < #2[[3]] &]]