How can I have random movements in my Cellular automaton model? For example, if the elements in a cell is much more than two or more neighboring cells I'd like to randomly choose a few neighbors to give some elements. I tried all the codes that came to my mind but my problem is that in Mathematica I have to be sure that the same time an element is living from a cell and is going to another. I thought of doing it using conditions but I am not sure how. Can anyone please help me?
Edit: the code I used so far
My actual code is very complicated so I will try to tell you what I have done with a simpler cellular automaton. I wanted to succeed movements in a Moore neighbourhood. Every cell in my cellular automaton has more than one individual (or none). I want to make random movements between my cells. I couldn't do this, so I tried the following code and in my cellular automaton I used it like you can see below.
w[i_, j_] :=
If[(i - 4) > j, -1, If[(i - 4) == j, 0, If[(j - 4) > i, 1, 0]]];
dogs[p, p1, p2,p3,p4,p5,p6,p7,p8]:=newp &[
newp = w[p, p1] + w[p, p2] + w[p, p3] + w[p, p4] + w[p, p5] +
w[p, p6] + w[p, p7] + w[p, p8]]
This code is doing movements, but is not exactly what I want because if a cell has 0 individuals in it and its neighbours all 5, then at the end it has 8 and its neighbours 4 but I don't want that because I don't want the cell with the less individuals in it to have more than its neighbours at the end. I want all of them to have close values in them and still have movements. I don't know how to do that in Mathematica.
A cellular automaton is not particularly complicated, so my first point of advice is to figure out exactly what you want. Then, I recommend you separate the classical transition rules from the "random" aspect you're introducing.
For instance, here is my implementation of Conway's Game of Life:
(* We abbreviate 'nbhd' for neighborhood *)
getNbhd[A_, i_, j_] := A[[i - 1 ;; i + 1, j - 1 ;; j + 1]];
evaluateCell[A_, i_, j_] :=
Module[{nbhd, cell = A[[i, j]], numNeighbors},
(* no man's land edge strategy *)
If[i == 1 || j == 1 || i == Length[A] || j == Length[A[[1]]],
Return[0]];
nbhd = getNbhd[A, i, j];
numNeighbors = Apply[Plus, Flatten[nbhd]];
If[cell == 1 && (numNeighbors - 1 < 2 || numNeighbors - 1 > 3),
Return[0]];
If[cell == 0 && numNeighbors == 3, Return[1]];
Return[cell];
];
evaluateAll[A_] := Table[evaluateCell[A, i, j],
{i, 1, Length[A]}, {j, 1, Length[A[[1]]]}];
After performing evaluateAll, you can search through the matrix for "lonely" cells and move them as you please.
For additional information about how the code works, and to see examples of the code in action, see my blog post on Conway's Life. It includes a Mathematica notebook with the full implementation and plenty of examples.
Related
I'm working on a script in mathematica that will take simulate a string held at either end and plucked, by solving the wave equation via numerical methods. (http://en.wikipedia.org/wiki/Wave_equation#Investigation_by_numerical_methods)
n = 5; (*The number of discreet elements to be used*)
L = 1.0; (*The length of the string that is vibrating*)
a = 1.0/3.0; (*The distance from the left side that the string is \
plucked at*)
T = 1; (*The tension in the string*)
[Rho] = 1; (*The length density of the string*)
y0 = 0.1; (*The vertical distance of the string pluck*)
[CapitalDelta]x = L/n; (*The length of each discreet element*)
m = ([Rho]*L)/n;(*The mass of each individual node*)
c = Sqrt[T/[Rho]];(*The speed at which waves in the string propogate*)
I set all my variables
Y[t] = Array[f[t], {n - 1, 1}];
MatrixForm(*Creates a vector size n-1 by 1 of functions \
representing each node*)
I define my Vector of nodal position functions
K = MatrixForm[
SparseArray[{Band[{1, 1}] -> -2, Band[{2, 1}] -> 1,
Band[{1, 2}] -> 1}, {n - 1,
n - 1}]](*Creates a matrix size n by n governing the coupling \
between each node*)
I create the stiffness matrix relating all the nodal functions to one another
Y0 = MatrixForm[
Table[Piecewise[{{(((i*L)/n)*y0)/a,
0 < ((i*L)/n) < a}, {(-((i*L)/n)*y0)/(L - a) + (y0*L)/(L - a),
a < ((i*L)/n) < L}}], {i, 1, n - 1}]]
I define the initial positions of each node using a piecewise function
NDSolve[{Y''[t] == (c/[CapitalDelta]x)^2 Y[t].K, Y[0] == Y0,
Y'[0] == 0},
Y, {t, 0, 10}];(*Numerically solves the system of second order DE's*)
Finally, This should solve for the values of the individual nodes, but it returns an error:
"NDSolve::ndinnt : Initial condition [Y0 table] is not a number or a rectangular array"
So , it would seem that I don't have a firm grasp on how matrices work in mathematica. I would greatly appreciate it if anyone could help me get this last line of code to run properly.
Thank you,
Brad
I don't think you should use MatrixForm when defining the matrices. MatrixForm is used to format a list of list as a matrix, usually when you display it. Try removing it and see if it works.
I have a black box algorithm that analyses a time series and "detects" certain events in the series. It returns a list of events, each containing a start time and end time. The events do not overlap.
I also have a list of the "true" events, again with start time and end time for each event, not overlapping.
I want to compare the two lists and match detected and true events that fall within a certain time tolerance (True Positives). The complication is that the algorithm may detect events that are not really there (False Positives) or might miss events that were there (False Negatives).
What is an algorithm that optimally pairs events from the two lists and leaves the proper events unpaired? I am pretty sure I am not the first one to tackle this problem and that such a method exists, but I haven't been able to find it, perhaps because I do not know the right terminology.
Speed requirement:
The lists will contain no more than a few hundred entries, and speed is not a major factor. Accuracy is more important. Anything taking less than a few seconds on an ordinary computer will be fine.
Here's a quadratic-time algorithm that gives a maximum likelihood estimate with respect to the following model. Let A1 < ... < Am be the true intervals and let B1 < ... < Bn be the reported intervals. The quantity sub(i, j) is the log-likelihood that Ai becomes Bj. The quantity del(i) is the log-likelihood that Ai is deleted. The quantity ins(j) is the log-likelihood that Bj is inserted. Make independence assumptions everywhere! I'm going to choose sub, del, and ins so that, for every i < i' and every j < j', we have
sub(i, j') + sub(i', j) <= max {sub(i, j ) + sub(i', j')
,del(i) + ins(j') + sub(i', j )
,sub(i, j') + del(i') + ins(j)
}.
This ensures that the optimal matching between intervals is noncrossing and thus that we can use the following Levenshtein-like dynamic program.
The dynamic program is presented as a memoized recursive function, score(i, j), that computes the optimal score of matching A1, ..., Ai with B1, ..., Bj. The root of the call tree is score(m, n). It can be modified to return the sequence of sub(i, j) operations in the optimal solution.
score(i, j) | i == 0 && j == 0 = 0
| i > 0 && j == 0 = del(i) + score(i - 1, 0 )
| i == 0 && j > 0 = ins(j) + score(0 , j - 1)
| i > 0 && j > 0 = max {sub(i, j) + score(i - 1, j - 1)
,del(i) + score(i - 1, j )
,ins(j) + score(i , j - 1)
}
Here are some possible definitions for sub, del, and ins. I'm not sure if they will be any good; you may want to multiply their values by constants or use powers other than 2. If Ai = [s, t] and Bj = [u, v], then define
sub(i, j) = -(|u - s|^2 + |v - t|^2)
del(i) = -(t - s)^2
ins(j) = -(v - u)^2.
(Apologies to the undoubtedly extant academic who published something like this in the bioinformatics literature many decades ago.)
please can you help me with creation of function in Wolfram Mathematica for magic square. I must create function MagicSquare[n_], which output is sqare matrix of first n^2 integers, and sum of these integers in every column, every row, and on diagonals must be the same. Please help me, I try this for a days and I failed. I need this for my school assignment.
Here is a simple brute-force approach. Note the check value m is the magic constant.
(Setting the random values to the array variables makes nifty use of HoldFirst.)
n = 3;
m = n (n^2 + 1)/2;
check = {0};
While[Unequal[Union[check], {m}],
Clear[s];
x = Table[s[i, j], {i, 1, n}, {j, 1, n}];
d1 = Diagonal[x];
d2 = Diagonal[Reverse[x]];
cols = Transpose[x];
vars = Flatten[x];
rand = RandomSample[Range[n^2], n^2];
MapThread[Function[{v, r}, v = r, HoldFirst], {vars, rand}];
check = Total /# Join[x, cols, {d1, d2}]];
MatrixForm[x]
8 3 4
1 5 9
6 7 2
Here is another brute force approach that works for n=3 ..
n = 3
m = n (n^2 + 1) /2
Select[
Partition[# , n] & /#
Permutations[Range[n^2]],
(Union #(Total /# # )) == {m} &&
(Union #(Total /# Transpose[#] )) == {m} &&
Total#Diagonal[#] == m &&
Total#Diagonal[Reverse##] == m & ][[1]] // MatrixForm
This has the advantage of immediately producing an out of memory error for larger n, while Chris' will run approximately forever. :)
I'm implementing a game called Neutreeko (5x5 board, each player has three paws, game ends when one of them forms a connected orthogonal or diagonal line) and am currently thinking about the most optimal way to check if the game has ended. I'm storing the state of the board in a one-dimensional array and I only figured the brute force approach in which I just check each row, column and every diagonal line of lenght 3 and 5 until I find a hit. Is there any better way of finding the end of game in such scenario?
If you store the board as a bitmap (with position i, j stored in bit i + j*5), you can do the checks quickly.
For example,
x & (x >> 1) & (x >> 2) & 0x739ce7
is non-zero if there's a horizontal row of three.
x & (x >> 5) & (x >> 10)
is non-zero if there's a vertical row of three.
x & (x >> 6) & (x >> 12) & 0x1ce7
is non-zero if there's a diagonal row of three (on a diagonal like (0,0),(1,1),(2,2)).
x & (x >> 4) & (x >> 8) & 0x739c
is non-zero if there's a diagonal row of three (on a diagonal like (2,0),(1,1),(0,2)).
These kinds of bitmask checks are very common in boardgame position evaluation.
I want to start by saying write what is easy to read, not micro-optimisations that you won't notice at run-time.
That said, this is how I'd do it:
It would be better to check the other pawns' positions relative to the first one, rather than brute forcing the entire board.
Further, since the board is square, you can work out positions much more easily in terms of the game board's elements since lines are made up of +1s, +4s, +5s, and +6s.
There would not be any decrements as we've found there are no pawns prior to a hit.
[ 0][ 1][ 2][ 3][ 4]
[ 5][ 6][ 7][ 8][ 9]
[10][11][12][13][14]
[15][16][17][18][19]
[20][21][22][23][24]
Say the first pawn was on 12.
You would only have to check 13, 16, 17, 18.
Why not 6? Since you've already shown there's no pawn on 0 or 6 hence would have been pointless to check.
After all, if you hit one pawn and then failed, you can skip that player's remaining spaces since they haven't got a line!
It the next pawn hits, then recognise what line you're matching, and see if that line continues to the only place available (14, 20, 22, 24 respectively).
Further optimisations could be made in making invalid lines whereby it's pointless to check for anything other than a +4 or +5 from the last column, etc.
While not as elegant or efficient as Anonymous' answer, one could also use a bitboard like this:
/*
parseInt("111",2) == 7
parseInt("1"
+ "00001"
+ "00001",2) == 1057
parseInt("1"
+ "00010"
+ "00100",2) == 1092
parseInt("100"
+ "00010"
+ "00001",2) == 4161
To win, a player's bit-board must represent a multiple of one of the masks;
the multiple must be a power of two; and the mask cannot straddle both sides
of the bit-board:
*/
function testWinner(board){
var i = 0,
masks = [7,1057,1092,4161],
winner = false
while (!winner && masks[i]){
winner = board % masks[i] == 0
&& !(board / masks[i] & (board / masks[i] - 1))
&& !(board & 17318416 && board & 1082401)
i++
}
return winner
}
I am working on an algorithm which calculates the determinant of any n*n matrix, here is my code:
Laplace[matrix_List] := Module[{a = matrix, newmatrix, result = 0},
If [Length[a] == 1, result = Total[Total[a]],
For [i = 1, i <= Length[a], i++,
newmatrix = Drop[a, {i}, {1}];
result = result + (-1)^(i + 1) *
Total[Total[Take[a, {i}, {1}]]]*
Laplace[newmatrix];
]
]; result]
It works recursively, it works for a 2*2 matrix(I have checked with Det[]),
but it doesn't work for any matrix of higher degree than 2!
I would like to solve this solution myself - I want to implement this myself, rather than simply using Det - but I would appreciate it if someone could explain what is wrong with the recursion here?
You should not calculate the determinant in a recursive way, it takes a lot of time. The simplest method is to take the first column and see if there is an element different from 0. If there isn't then the determinant is equal to 0. Otherwise take that element and for every line in the matrix different from that of the chosen element substract the line of the chosen element multiplied with the symetric of the first element of the current line. That substraction should leave you with a line which has 0 as its first element. Then you can eliminate the first column and the line of the chosen element and multiply the n-1 order determinant with (-1)^(line_index+column_index)*chosen_element.
mat = {{a11,a12,a13,a14]}, {a21,a22,a23,a24}, {a31,a32,a33,a34}, {a41,a42,a43,a44}};
det = Sum[Signature[p[[j]]]*
Product[mat[[i, p[[j, i]]]], {i, 1, Length[mat]}], {j, 1, 4!}]
this will produce a correct result! det===Det[mat]
Good Luck