# Code golf chromostereopsis illusion

I am trying to maximally shorten the code (code golf) for chromostereopsis illusion by Akiyoshi Kitaoka:

The point is to make it: (1) identical to his image, (2) make code as short as possible. My take is below. Can you post a shorter answer? Least number of characters wins. Please mention count of characters in your answer. Mine is 150. I prefer to keep randomness free of fix (like SeedRandom). By identical image I meant basic image parameters -- size of objects and image.

r=RandomChoice;b=Black;s=28;f=x^2+y^2;
ArrayPlot[Table[Which[f<300,r[{b,Red}],300<=f<440,b,440<=f,r[{b,Blue}]],
{x,-s,s},{y,-s,s}],PixelConstrained->10]


• You'll probably get better answers on codegolf.SE! Sep 9 at 16:36
• To obtain an identical image you need to include SeedRandom[1]; (or some other single digit seed). Sep 9 at 16:36
• Does this 45 character version in Mathematica count? Import["https://i.stack.imgur.com/O6qfm.jpg"]. Probably not.
– JimB
Sep 9 at 19:22
• Just wanted to say, this is a stunning illusion! Sep 10 at 16:00
• Here's a 26 character solution that kinda sorta follows the spirit of the question: ARPublish[Ball[]][[2,2,1]] Sep 11 at 2:50

Hue[2⌊2#⌋/3,1,⌊2Random[]⌋Boole@¬.44<#<.53]&~RadialGradientImage~57


old versions

79: ArrayPlot@Array[{Red,1,Blue}〚2+Sign@⌊#^2+#2^2-3⌋⌊2Random[]⌋〛&,{57,57},{{-3,3}}]

85: ArrayPlot@Map[{Blue,1,Red}〚⌊2Random[]⌋#+2〛&,#[2√110,57]+#[10√3,57]&@DiskMatrix-1,{2}]

• Wow! Now if only RadialGradientImage wasn't so long... Sep 11 at 1:35
• You beat me to an answer with RadialGradientImage; I was relieved you left room to improve :)
Sep 11 at 2:04
• Using Hue is such a creative solution. A great way to decouple the conditionals! Sep 11 at 2:40
• +1 Nicely played! Thank you :-) Sep 11 at 21:53
• Any particular reason for code golf on this problem? I want more MMA golf!
Sep 12 at 2:08

84 characters:

str = "ArrayPlot@Array[1+Sign@\[LeftFloor](#^2+#2^2-300)/140\
\[RightFloor]Random@1\[LeftDoubleBracket]0\[RightDoubleBracket]/.{0\
\[Rule]Red,2\[Rule]Blue}&,{57,57},-28]";

StringLength @ str


84

ToExpression @ str


where I used key ideas from Roman's and azerbajdzan's anwers.

• +1 Thank you. \[Rule] should probably be ->. Did you count unicode characters? Cool trick with floor. Sep 9 at 19:02
• StringLength for "->" and for "\[Rule]" (or Esc -> Esc) are 2 and 1, respectively. So used the latter to save 1 character.
– kglr
Sep 9 at 19:15

115 characters (or 110, see below):

ArrayPlot[Array[Clip@Floor[(#^2+#2^2-300)/140]RandomInteger[]&,{57,57},-28],ColorRules->{1->Blue,0->Black,-1->Red}]


If we're counting characters, not bytes, then we can use fancy ⌊…⌋ characters instead of the Floor function and do it in 110 characters:

ArrayPlot[Array[Clip@⌊(#^2+#2^2-300)/140⌋RandomInteger[]&,{57,57},-28],ColorRules->{1->Blue,0->Black,-1->Red}]


– Neil
Sep 11 at 20:43

92 characters if colors are controllable:

w=49;Image[RandomInteger[1,{w,w}](1-16~#~w+2 12~#~w)/.{0->Black,1->Blue,2->Red}]&@DiskMatrix


86 characters otherwise:

w=49;Image@Transpose[1~RandomInteger~{w,w}#&/@{12~#~w,0,1-16~#~w},{3,1,2}]&@DiskMatrix


• A possible variant, same characters: w=49;Image[1~RandomInteger~{w,w}#&/@{12~#~w,0,1-16~#~w},Interleaving->0>1]&@DiskMatrix Sep 10 at 14:36
• +1 super cool :-) Sep 10 at 17:13
• @VitaliyKaurov Thanks. I tried my best with constraint of Image output. :) Sep 10 at 18:41
• @chyanog Nice one! I didn't use Interleaving version only because True is too long. But with your 0>1 trick it's better than mine as it's one function layer less. :) Sep 10 at 18:43
• replace {3,1,2} with 3\[TwoWayRule]1 to get 82 characters.
– kglr
Sep 11 at 7:55

The symbol  is equivalent to -> and works well when you copy & paste the code from here to Mathematica.

Code length is 81.

code1 = "ArrayPlot@Array[1+Sign@⌊#^2+#2^2-3⌋⌊2Random[]⌋/.{0Red,2Blue}&,{57,57},{{-3,3}}]";
StringLength[code1]
code1//ToExpression

(* 81 *)

code2 = "21~#~57+18~#~57+1~RandomInteger~{57,57}/.{21,3Red,0Blue}&@DiskMatrix//ArrayPlot";
StringLength[code2]
code2 // ToExpression

(* 82 *)


code3="ImageApply[⌊2Random[]⌋#&,21~#~57+18~#~57/.{2Red,0Blue}&@DiskMatrix//ArrayPlot]";
StringLength[code3]
code3//ToExpression

(* 80 *)


• +1 great thank you Sep 10 at 17:40
• I know the question asks for character count, but code golf is usually measured in bytes. This is a 92 byte answer. Sep 11 at 8:02
• Yes, I am answering the question, all posts in this thread count characters, why you chose this particular post? Sep 11 at 8:58

74 characters, incorporating Adam's method for rounding:

If[#<.45(r=⌊2Random[]⌋),Red,If[r#>.54,Blue,Black]]&~RadialGradientImage~57


Old versions:

77 characters:

If[#<.45(r=Random@Integer),Red,If[r#>.54,Blue,Black]]&~RadialGradientImage~57


StringLength["If[#<.45(r=Random@Integer),Red,If[r#>.54,Blue,Black]]&~RadialGradientImage~57"]

77

• +1 RadialGradientImage what a wonderful find, thank you ! Sep 11 at 21:53

Not fewer characters, but just for fun: 125 characters

Graphics[{RandomChoice[{t = Total[#^2 & /@ #];
If[t < 300, Red, If[t >= 440, Blue, Black]], Black}],
Rectangle[#]} & /@ Tuples[Range[-28, 28], 2]]


Just another variation using GaussianMatrix:

Image@Map[{#,0,1-3#}Sign[#-3Sign@#]&[⌊2Random[]⌋⌊10^4#⌋]&,GaussianMatrix[{28,21}],{2}]


86 Characters ..

94 characters:

ArrayPlot@
Array[RandomChoice[{t = #^2 + #2^2;
If[t < 300, Red, If[t >= 440, Blue, Black]], 1}] &, {57, 57}, -28]


Shortening Melago's method to 87 characters:

ArrayPlot@
Array[RandomChoice@{1, If[# . # < 300, Red, If[# . # < 440, 1, Blue]]&@{##}}&,
{57,57}, -28]


• Nice! I should keep pure functions in mind more often. Sep 10 at 18:23
n = 57;
RandomInteger[1, {n, n}] (#[22, n] - 2 #[16, n] + 2) &@DiskMatrix //
ArrayPlot[#, ColorRules -> {2 -> Blue, 0 -> Black, 1 -> Red}] &


StringLength@"n=57;\[IndentingNewLine]RandomInteger[1,{n,n}](#[22,n]-\
2#[18,n]+2) &@DiskMatrix \
//ArrayPlot[#,ColorRules\[Rule]{2\[Rule]Blue,0\[Rule]Black,1\[Rule]\
Red}]&"


111