3
$\begingroup$

I would like to solve my birth and death problem.

SeedRandom[124]
With[{λ = 3, μ = 2, initialPopulation = 10, 
numOfReaction = 5, numOfSim = 1}, 
ListLinePlot[
  sim = birthDeath[λ, μ, initialPopulation, 
    numOfReaction], InterpolationOrder -> 0, 
  PlotStyle -> {Black, Thick}, Frame -> True, 
  GridLines -> Transpose@sim, FrameLabel -> {"Time", "Population"}, 
  ImageSize -> 300]]

enter image description here

And one possibleenter image description here path is

sim={{0, 10}, {0.168871, 9}, {0.824082, 10}, {0.92576, 11}, {0.956336, 12}, {1.06251, 11}}

Differences@sim[[All, 1]]

deltaT={0.168871, 0.655211, 0.101678, 0.0305756, 0.106177}

after 0.168871s there is a death but it could be a birth and after 0.655211s there is birth but it could be death and so on.

Initial population is 10 and end up with population 11 after some number of birth and death.Number of reaction is constant which is 5 in this case namely 2 death, 3 birth. I would like to find All path between initial population and last population. I thought I can use Graph and find all path that satisfy the condition.

Do you think it is better to use Linear Integer Programming? Total population cannot be negative. Sum of #birth and #death=last population-initial population. birth and death are integer.

Assume I have $5\times5$ GridGraph. I would like to find all path (not necessarily shortest ) under some condition.

  1. Start from initial population and always move to Right, Up Or Down at the beginning.
  2. You cannot move Right and Right consecutively. Meaning that after Right either move UP or Down if possible.
  3. Never move Left.

Here is the sample code I got from Help page which violets some rules I have.

 s = 1;
    t = 16;
    g = GridGraph[{4, 4}, VertexSize -> {s -> Medium, t -> Medium}]

path=FindPath[g, s, t, {GraphDistance[g, s, t]}, All]

HighlightGraph[g, PathGraph[#]] & /@ path

enter image description here

$\endgroup$
  • $\begingroup$ If "you always move to the right at the beginning" and "you cannot move right and right," then your problem is a general shortest search on a $3 \times 3$ grid. All valid paths "start" at the location $(1,1)$ and exclude the three "right-right" paths that remain. $\endgroup$ – David G. Stork Jan 20 '18 at 1:35
  • $\begingroup$ Yes you right. Let me fix my condition. $\endgroup$ – OkkesDulgerci Jan 20 '18 at 1:39
  • $\begingroup$ I just realized that graph approach may not be a good idea. $\endgroup$ – OkkesDulgerci Jan 20 '18 at 2:06
  • $\begingroup$ loosely/ tangentially related: Counting all perpendicular paths crossing a grid $\endgroup$ – kglr Jan 20 '18 at 2:35
  • $\begingroup$ What about Up + Up? Or Up+Down? $\endgroup$ – Carl Woll Jan 20 '18 at 2:43
3
$\begingroup$

Here is one idea. First, let's look at the vertex labels:

g = GridGraph[{5, 5}, VertexLabels -> "Name"]

enter image description here

Since FindPath doesn't revisit vertices, we don't have to worry about up + down paths. The paths that FindPath generates that are not allowed are the up + up, down + down and right + right (in addition to left). I use the following to encode this information:

up = {
    {1, 2, 3}, {2, 3, 4}, {3, 4, 5},
    {6, 7, 8}, {7, 8, 9}, {8, 9, 10},
    {11, 12, 13}, {12, 13, 14}, {13, 14, 15},
    {16, 17, 18}, {17, 18, 19}, {18, 19, 20},
    {21, 22, 23}, {22, 23, 24}, {23, 24, 25}
};

down = Reverse /@ up;

right = {
    {1, 6, 11}, {6, 11, 16}, {11, 16, 21},
    {2, 7, 12}, {7, 12, 17}, {12, 17, 22},
    {3, 8, 13}, {8, 13, 18}, {13, 18, 23},
    {4, 9, 14}, {9, 14, 19}, {14, 19, 24},
    {5, 10, 15}, {10, 15, 20}, {15, 20, 25}
};

left = {
    {6, 1}, {11, 6}, {16, 11}, {21, 16},
    {7, 2}, {12, 7}, {17, 12}, {22, 17},
    {8, 3}, {13, 8}, {18, 13}, {23, 18},
    {9, 4}, {14, 9}, {19, 14}, {24, 19},
    {10, 5}, {15, 10}, {20, 15}, {25, 20}
};

Using the above data, we can create a function to determine whether a path is allowed or not:

goodQ[path_, set_, len_] := Max[
    Length[LongestCommonSubsequence[path, #]]& /@ set
] < len

goodQ[path_] := And[
    goodQ[path, left, 2],
    goodQ[path, right, 3],
    goodQ[path, up, 3],
    goodQ[path, down, 3]
]

Finally, we can construct all the paths and then select only the good ones:

paths = Join @@ Table[
    FindPath[g, 1, end, 9, All],
    {end, 21, 25}
];
good = Select[paths, goodQ]

{{1, 6, 7, 12, 13, 18, 17, 22, 21}, {1, 6, 7, 12, 11, 16, 17, 22, 21}, {1, 2, 7, 8, 13, 12, 17, 16, 21}, {1, 2, 7, 6, 11, 12, 17, 16, 21}, {1, 6, 7, 12, 13, 18, 17, 22}, {1, 6, 7, 12, 11, 16, 17, 22}, {1, 2, 7, 8, 13, 14, 19, 18, 23, 22}, {1, 2, 7, 8, 13, 12, 17, 18, 23, 22}, {1, 2, 7, 8, 13, 12, 17, 16, 21, 22}, {1, 2, 7, 6, 11, 12, 17, 18, 23, 22}, {1, 2, 7, 6, 11, 12, 17, 16, 21, 22}, {1, 6, 7, 12, 13, 18, 19, 24, 23}, {1, 6, 7, 12, 13, 18, 17, 22, 23}, {1, 6, 7, 12, 11, 16, 17, 22, 23}, {1, 2, 7, 8, 13, 14, 19, 18, 23}, {1, 2, 7, 8, 13, 12, 17, 18, 23}, {1, 2, 7, 6, 11, 12, 17, 18, 23}, {1, 6, 7, 12, 13, 18, 19, 24}, {1, 2, 7, 8, 13, 14, 19, 20, 25, 24}, {1, 2, 7, 8, 13, 14, 19, 18, 23, 24}, {1, 2, 7, 8, 13, 12, 17, 18, 23, 24}, {1, 2, 7, 6, 11, 12, 17, 18, 23, 24}, {1, 6, 7, 12, 13, 18, 19, 24, 25}, {1, 2, 7, 8, 13, 14, 19, 20, 25}}

Visualization:

Multicolumn[
    HighlightGraph[
        Graph[g, EdgeStyle->LightGray, VertexLabels->None],
        BlockMap[Apply[UndirectedEdge], #, 2, 1]
    ]& /@ good,
    3
]

enter image description here

Addendum

If we only want paths that start at 1 and end at 22, with 3 up steps and 2 down steps, then the path has length 9:

paths = FindPath[g, 1, 22, {9}, All];
good = Select[paths, goodQ]

{{1, 2, 7, 8, 13, 14, 19, 18, 23, 22}, {1, 2, 7, 8, 13, 12, 17, 18, 23, 22}, {1, 2, 7, 8, 13, 12, 17, 16, 21, 22}, {1, 2, 7, 6, 11, 12, 17, 18, 23, 22}, {1, 2, 7, 6, 11, 12, 17, 16, 21, 22}}

Visualization:

Multicolumn[
    HighlightGraph[
        Graph[g, EdgeStyle->LightGray, VertexLabels->None],
        BlockMap[Apply[UndirectedEdge], #, 2, 1]
    ]& /@ good,
    3
]

enter image description here

Update

Here's a version of goodQ that should generalize better:

goodQ[path_] := With[{d = Differences[path]},
    With[{odd = Tally[Abs[d][[1;;-1;;2]]], even = Tally[Abs[d][[2;;-1;;2]]]},
        Min[d]>=-1 && Length[odd]==1 && Length[even]==1 &&odd!=even
    ]
]

Check:

paths = Join@@Table[FindPath[g, 1, end, 9, All], {end, 21, 25}];
good = Select[paths, goodQ]

{{1, 6, 7, 12, 13, 18, 17, 22, 21}, {1, 6, 7, 12, 11, 16, 17, 22, 21}, {1, 2, 7, 8, 13, 12, 17, 16, 21}, {1, 2, 7, 6, 11, 12, 17, 16, 21}, {1, 6, 7, 12, 13, 18, 17, 22}, {1, 6, 7, 12, 11, 16, 17, 22}, {1, 2, 7, 8, 13, 14, 19, 18, 23, 22}, {1, 2, 7, 8, 13, 12, 17, 18, 23, 22}, {1, 2, 7, 8, 13, 12, 17, 16, 21, 22}, {1, 2, 7, 6, 11, 12, 17, 18, 23, 22}, {1, 2, 7, 6, 11, 12, 17, 16, 21, 22}, {1, 6, 7, 12, 13, 18, 19, 24, 23}, {1, 6, 7, 12, 13, 18, 17, 22, 23}, {1, 6, 7, 12, 11, 16, 17, 22, 23}, {1, 2, 7, 8, 13, 14, 19, 18, 23}, {1, 2, 7, 8, 13, 12, 17, 18, 23}, {1, 2, 7, 6, 11, 12, 17, 18, 23}, {1, 6, 7, 12, 13, 18, 19, 24}, {1, 2, 7, 8, 13, 14, 19, 20, 25, 24}, {1, 2, 7, 8, 13, 14, 19, 18, 23, 24}, {1, 2, 7, 8, 13, 12, 17, 18, 23, 24}, {1, 2, 7, 6, 11, 12, 17, 18, 23, 24}, {1, 6, 7, 12, 13, 18, 19, 24, 25}, {1, 2, 7, 8, 13, 14, 19, 20, 25}}

Same answer as before.

| improve this answer | |
$\endgroup$
  • $\begingroup$ Number of birth and death shouldn't change. Since I have 2 down (death) and 3 up (birth), path should 2 down (death) and 3 up (birth), order may change. It should start at the position {0, 10} and end at the position {1.06251, 11} $\endgroup$ – OkkesDulgerci Jan 20 '18 at 4:47
  • $\begingroup$ your method is promising but what if I wanna try 6x6 or other grid size, then defining vectors(left, right, up) will be cumbersome. Can your approach be generalized? $\endgroup$ – OkkesDulgerci Feb 14 '18 at 23:06

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.