Message Boards Message Boards

Code golf chromostereopsis illusion

Vitaliy Kaurov, WOLFRAM Research
Posted 8 months ago

I talk about this illusion in my Linkedin series. I am trying to maximally shorten the code (code golf) for chromostereopsis illusion by Akiyoshi Kitaoka:

https://twitter.com/AkiyoshiKitaoka/status/1700061353346798019

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]

enter image description here
POSTED BY: Vitaliy Kaurov
8 Replies
Sort By:

I talk about this illusion in my Linkedin series. Amazing 66 characters solution by Adam on Mathematica Stack Exchange Code Golf I hosted:

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

That was a play on another amazing 74 characters solution by @Greg Hurst 

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

Yet another version I enjoyed was solution by Azerbajdzan with 80 characters:

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

enter image description here
POSTED BY: Vitaliy Kaurov
Rohit Namjoshi
Rohit Namjoshi
Posted 8 months ago

There are several interesting solutions in the MSE crosspost.
POSTED BY: Rohit Namjoshi

Rearranging to remove r (combined with the tips from the other responses) can get it down to 109 characters:

ArrayPlot[Array[RandomChoice@{1,If[(f=#^2+#2^2)<300,Red,If[f<400,1,Blue]]}&,{57,57},-28],PlotRangePadding->0]

Edit: Swapped RandomChoice[{…}] for RandomChoice@{…} to remove 1 character.
POSTED BY: Daniel Robinson

Nested If is smaller than Which in this case... If[f < 300, r[{b, Red}], If[f < 440, b, r[{b, Blue}]]]
POSTED BY: Jon McLoone

-17 characters:

r=RandomChoice;b=Black;ArrayPlot[Array[(f=#^2+#2^2;Which[f<300,r@{b,Red},f<400,b,True,r@{b,Blue}])&,{57,57},-28],PixelConstrained->10]
POSTED BY: Ian Ford

Very nice sugar syntax shaving off. And I forgot about compactness of Array. Thank you :-)

POSTED BY: Vitaliy Kaurov

It is a trivial change, but anyway: If the obsolete

PixelConstrained->10

gets replaced by

PlotRangePadding->0

one character is saved.
POSTED BY: Henrik Schachner

Annother (trivial) variation to Ian's elegant approach: The definition of b=Black; is not necessary - you just write Black as 1:

r = RandomChoice; ArrayPlot[Array[(f = #^2 + #2^2;Which[f < 300, r@{1, Red}, f < 400, 1, True, r@{1, Blue}]) &, {57,57}, -28], PlotRangePadding -> 0]

This uses 125 characters.
POSTED BY: Henrik Schachner
Reply to this discussion
Community posts can be styled and formatted using the Markdown syntax.
Tag limit exceeded
Note: Only the first five people you tag will receive an email notification; the other tagged names will appear as links to their profiles.
Reply Preview
Attachments
Remove
or Discard

Group Abstract Group Abstract