5
$\begingroup$

enter image description hereI am trying to make a function that takes a list and models splitting lanes in traffic. The list below is a 1-lane road with cars a, b, and c in them, moving from left to right, and I want them to fill the available lanes to the right. {{{a,b,c}}//MatrixForm,{{0,0,0},{0,0,0}}//MatrixForm

Is there a way to define a function like that? I want something like... for one discrete timestep, have car c move into the top (left) lane. Clear[traffic]; traffic[{{a,b,c}}]:={{{0,a,b}},{{c,0,0},{0,0,0}}} and so on.

$\endgroup$
  • 1
    $\begingroup$ How do you decide that $c$ and $a$ will go to the top lane and $b$ to the bottom one? $\endgroup$ – anderstood Jan 20 '17 at 17:02
4
$\begingroup$

This is one way:

traffic[{lane_, lanes_}] := Block[{newlanes, free},
  {free} = FirstPosition[lanes[[All, 1]], 0];
  newlanes = 
   Transpose[
    Join[{ConstantArray[0, Length@lanes]}, Most[Transpose[lanes]]]];
  newlanes[[free, 1]] = lane[[-1]];
  {Prepend[Most[lane], 0], newlanes}
  ]

free finds the first available lane from the top, then the single lane and mulitple lanes are updated. Note I've assumed a single incoming lane, but the multiple lanes can be any rectangular matrix. The flow in the OP can be produced by

NestList[traffic, {{a, b, c}, {{0, 0, 0}, {0, 0, 0}}}, 3]

Please let me know if you also want the incoming lane to possibly be multi-laned.

$\endgroup$
  • 1
    $\begingroup$ ArrayPad[] makes things neat: traffic[{lane_, lanes_}] := Block[{newlanes, free}, {free} = FirstPosition[lanes[[All, 1]], 0]; newlanes = ReplacePart[ArrayPad[lanes, {{0, 0}, {1, -1}}], {free, 1} -> lane[[-1]]]; {ArrayPad[lane, {1, -1}], newlanes}] $\endgroup$ – J. M. will be back soon Jan 22 '17 at 10:32
3
$\begingroup$
xx = Partition[Insert[{a, b, c}, 0, List /@ {2, 2, -1}], 2];

Table[Row[ MatrixForm /@ {List@ArrayPad[{a, b, c}, {i, -i}], 
    ArrayPad[Transpose[xx], {{0}, {i - 3, 3 - i}}]}], {i, 0, 3}]

Mathematica graphics

$\endgroup$
0
$\begingroup$

Update

The code I first posted seemed way too long for this operation so I tried again. I chose to use a different format to simplify my construction.

f[in_?VectorQ] := {in, {0, 0} & /@ in}

f[{{a__, b_}, {m__, _}}] := {{0, a}, {If[{m}[[1, 1]] === 0, {b, 0}, {0, b}], m}}

format[{v_, m_}] := Row[MatrixForm /@ {{v}, m\[Transpose]}]

Use:

format /@ Rest @ NestList[f, {a, b, c}, 4]

enter image description here


Old code

My interpretation of what you want. More verbose than I like but I found it an interesting problem.

f1[x_][ls_] := FoldList[ArrayPad[#, {x, -x}] &, ls, ls]

f2[in_] := Total @ Partition[DiagonalMatrix @ in, 2, 2, 1, 0]

f3[in_] := {f1[1][in], Reverse[f1[-1] /@ f2[in]\[Transpose]]}\[Transpose]

format[{in_, out_}] := Row[MatrixForm /@ {{in}, out}]

Use:

f3[{a, b, c}]

format /@ %
{{{a, b, c}, {{0, 0, 0}, {0, 0, 0}}},
 {{0, a, b}, {{c, 0, 0}, {0, 0, 0}}},
 {{0, 0, a}, {{0, c, 0}, {b, 0, 0}}},
 {{0, 0, 0}, {{a, 0, c}, {0, b, 0}}}}

enter image description here

$\endgroup$
  • $\begingroup$ Just a heads up: The output under format /@ Rest @ NestList[f, {a, b, c, d, e}, 6]; does not match the input ;) $\endgroup$ – Marius Ladegård Meyer Jan 21 '17 at 14:30
  • $\begingroup$ @Marius Thanks; corrected (I think.) $\endgroup$ – Mr.Wizard Jan 22 '17 at 3:19

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.