Well, this is how the array looks like:
I came up with this code:
n = 10;
Nest[ArrayPad[#, 1, 1 - #[[1, 1]]] &, {{1}}, n] /. {1 -> "*"}
Any better ideas?
Mathematica Stack Exchange is a question and answer site for users of Wolfram Mathematica. It only takes a minute to sign up.
Sign up to join this communityWell, this is how the array looks like:
I came up with this code:
n = 10;
Nest[ArrayPad[#, 1, 1 - #[[1, 1]]] &, {{1}}, n] /. {1 -> "*"}
Any better ideas?
Via CellularAutomaton
:
ruleFn[{{_, _, _}, {_, 0, _}, {_, _, _}}, step_] := 1;
ruleFn[{{_, _, _}, {_, 1, _}, {_, _, _}}?(MemberQ[#, 0, 2] &), step_] := 0;
ruleFn[{{1, 1, 1}, {1, 1, 1}, {1, 1, 1}}, step_] := 1;
CellularAutomaton[{ruleFn, {}, {1, 1}}, {{{0}}, 1}, {{{9}}}] /. 1 -> "*" // Grid
Edit: For those who really like obfuscated CAs:
Grid[CellularAutomaton[
{6704108548762591141713703895184498446288891439307603869437298727894782281512658462491554691453382697921609151728673186802143641955019044568101339107753983,
2, {1, 1}}, {{{0}}, 1}, {{{9}}}] /. 1 -> "*"]
...or just like really large numbers.
CA
, all the other answers are nice too.
$\endgroup$
– mmjang
Jun 11 '13 at 4:08
mat2
. I know you didn't specify performance as your primary goal but this seems like a lot of code for a very slow function. (Sorry Michael; I'm usually a fan of your answers but this just seems impractical.)
$\endgroup$
– Mr.Wizard
Jun 11 '13 at 14:55
Here's a recursive approach:
f[1] = {{1}};
f[x_] := ArrayPad[f[x - 1], 1, Boole@OddQ@x];
To apply it and display
f[8] //. 1 -> "*" // MatrixForm
I learned this trick from rm -rf in this post which has a great explanation of a simple recursive function. This f[ ]
works for both even and odd matrix sizes.
Nest[ArrayPad[#, 1, Boole@EvenQ@First@#] &, {{1}}, 7] //. 1 -> "*" // Grid
.
$\endgroup$
– chyanog
Jun 10 '13 at 17:15
Update
Simpler way of generating a "concentric" matrix, without having to convert to an image to apply a distance transform:
With[{size = 11},
Array[Max[#1, #2, size + 1 - #1, size + 1 - #2] &, {size, size}]
/. {_?OddQ -> "0", _?EvenQ -> "*"}]
End update
Here's a hare-brained implementation that uses DistanceTransform[]
:
First create an image with a single background (value 0) pixel at the center, and remaining pixels all foreground (value 1):
img = Image[SparseArray[{6, 6} -> 0, {11, 11}, 1]]
Take the distance transform with the chessboard metric:
mat = Round@ImageData@DistanceTransform[img, DistanceFunction -> ChessboardDistance]
giving
Now simply use rule-based replacement
mat /. {_?EvenQ -> "*", _?OddQ -> "0"} // MatrixForm
to get the desired result.
I like Bill's recursive approach. Here's another version using ArrayPad
and Fold
:
nested[n_Integer] := Fold[ArrayPad[#, 1, (-1)^#2] &, {{1}}, Range[n]] /. {-1 -> 0, 1 -> "*"}
nested[10] // MatrixForm
Clear[nestmatrix]
nestmatrix[width_] := SparseArray[{{i_, j_} /;
EvenQ[Ceiling[Norm[{i, j} - (width + 1)/2, ∞]]] :>
"*"}, width {1, 1}, 0] // Normal
{#, Grid[
nestmatrix[#] /.
"*" -> Item["*", Background -> Lighter[Red, .7]],
ItemSize -> All,
Frame -> All,
FrameStyle -> GrayLevel[.8]]} & /@ Range[6] //
Grid[#\[Transpose], Frame -> All] &
You can of course replace EvenQ
with OddQ
to "reverse" the order.
The CellularAutomaton
is very cool!
Another solution based on how * and 0 positions differ is given below:
f[n_] := Table[If[Mod[Max[Abs[i], Abs[j]], 2] == 0, "*", "0"],
{i, -n, n}, {j, -n, n}];
f[10]
SparseArray[]
version: f[n_Integer] := SparseArray[{i_, j_} /; EvenQ[Max[Abs[i - n - 1], Abs[j - n - 1]]] :> "*", {2 n + 1, 2 n + 1}]
$\endgroup$
– J. M.'s ennui♦
Jun 11 '13 at 12:41
It's surprising that the following For
loop approach is so fast (in fact it seems to be the fastest one until now! ):
(* n is the order of the matrix *)
n = 301;
mat = ConstantArray["*", {n, n}];
mid = (1 + n)/2;
mat[[mid, mid]] = 0;
For[i = 2, mid - i >= 1, i += 2,
mat[[mid - i, mid - i ;; mid + i]] = 0;
mat[[mid + i, mid - i ;; mid + i]] = 0;
mat[[mid - i + 1 ;; mid + i - 1, mid - i]] = 0;
mat[[mid - i + 1 ;; mid + i - 1, mid + i]] = 0]
Here's the snapshot for the test result:
You may think that this code may be improved by changing the For
loop into Do
or Nest
, but again, it's surprising that Do
and Nest
help little here, and I had a hard time in getting the boundary of the iterator. (I'm really bad at that! And thanks for the help of @chyanog ! )
n = 301;
mat = ConstantArray["*", {n, n}];
mid = (1 + n)/2;
mat[[mid, mid]] = 0;
Do[mat[[mid - i, mid - i ;; mid + i]] = 0;
mat[[mid + i, mid - i ;; mid + i]] = 0;
mat[[mid - i + 1 ;; mid + i - 1, mid - i]] = 0;
mat[[mid - i + 1 ;; mid + i - 1, mid + i]] = 0;, {i, 2, mid - 1, 2}]
n = 301;
mat = ConstantArray["*", {n, n}];
mid = (1 + n)/2;
mat[[mid, mid]] = 0;
i = 2;
Nest[(mat[[mid - i, mid - i ;; mid + i]] = 0;
mat[[mid + i, mid - i ;; mid + i]] = 0;
mat[[mid - i + 1 ;; mid + i - 1, mid - i]] = 0;
mat[[mid - i + 1 ;; mid + i - 1, mid + i]] = 0; i += 2;) &, , Floor[(mid - 1)/2]]
Nest
at very first, but later I found that the speed will barely change even if I use Do
or For
……
$\endgroup$
– xzczd
Jun 11 '13 at 5:49
A bit complicated, but:
With[{n = 31},
SparseArray[{i_, j_} /;
(EvenQ[i] && (i <= j <= n - i + 1 || n - i + 1 <= j <= i)) ||
(EvenQ[j] && (j <= i <= n - j + 1 || n - j + 1 <= i <= j)) :> "*",
{n, n}]]
n
must be odd, of course.
As noted in the comments by chyanog, one might want to use Min[]
/Max[]
for the second set of tests for each index. Here's an alternative:
With[{n = 31},
SparseArray[{i_, j_} /;
(EvenQ[i] && IntervalMemberQ[Interval[{i, n - i + 1}], j]) ||
(EvenQ[j] && IntervalMemberQ[Interval[{j, n - j + 1}], i]) :> "*",
{n, n}]]
SparseArray
with Condition
causes it to test all possible positions and store {position}
and value
for all that match, in this case storing ~half the positions and a long list with only "*"s in it
$\endgroup$
– ssch
Jun 10 '13 at 17:07
ByteCount[mm]/ByteCount[Normal[mm]]
(where mm
is the sparse array), it only needs more or less 2/3 of the storage for the full array; I get similar savings for larger dimensions.
$\endgroup$
– J. M.'s ennui♦
Jun 10 '13 at 17:11
Min[]
and Max[]
to compress to a single interval...
$\endgroup$
– J. M.'s ennui♦
Jun 11 '13 at 6:15
At the risk of flogging this equine quadruped post mortem, here's yet another:
Grid[
MorphologicalTransform[
SparseArray[{17, 17} -> 1, {33, 33}, 0],
{"Fill", "Clean", "Flip"}, 17] /. 1 -> "*"]
using the strange options in MorphologicalTransform
. Picture unnecessary...
I'm trying to do it differently but it's hard with so many good answers.
Hopefully this brings something unique:
mat[n_] := "*" Mod[1 - Array[Max@Abs@{##} &, 2n + {1,1}, -n], 2]
mat[5] // Grid
I thought using multiplication was clever but it appears replacement is faster when working with strings.
mat2[n_] := Mod[1 - Array[Max@Abs@{##} &, 2 n + {1, 1}, -n], 2] /. {1 -> "*"}
mat[500] // Timing // First
mat2[500] // Timing // First
0.437
0.234
p = {"*", 0};
n = 5;
Nest[ArrayPad[#, 1, First[p = p[[{2, 1}]]]] &, {{"*"}}, n] // TeXForm
$\left( \begin{array}{ccccccccccc} 0 & 0 & 0 & 0 & 0 & 0 & 0 & 0 & 0 & 0 & 0 \\ 0 & * & * & * & * & * & * & * & * & * & 0 \\ 0 & * & 0 & 0 & 0 & 0 & 0 & 0 & 0 & * & 0 \\ 0 & * & 0 & * & * & * & * & * & 0 & * & 0 \\ 0 & * & 0 & * & 0 & 0 & 0 & * & 0 & * & 0 \\ 0 & * & 0 & * & 0 & * & 0 & * & 0 & * & 0 \\ 0 & * & 0 & * & 0 & 0 & 0 & * & 0 & * & 0 \\ 0 & * & 0 & * & * & * & * & * & 0 & * & 0 \\ 0 & * & 0 & 0 & 0 & 0 & 0 & 0 & 0 & * & 0 \\ 0 & * & * & * & * & * & * & * & * & * & 0 \\ 0 & 0 & 0 & 0 & 0 & 0 & 0 & 0 & 0 & 0 & 0 \\ \end{array} \right)$
Also
Fold[ArrayPad[#, 1, p[[#2]]] &, {{"*"}}, Mod[Range @ n, 2, 1]]
Nest[ArrayPad[#, 1, #[[1, 1]] /. {0 -> "*", "*" -> 0}] &, {{"*"}}, n]