9
$\begingroup$

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

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

11 Answers 11

Reset to default
10
$\begingroup$

66 characters, adapted from Greg Hurst's answer:

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}]

img

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

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

enter image description here

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

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

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}]

enter image description here

Improve this answer
$\endgroup$
1
  • $\begingroup$ Your 110-character answer is 114 bytes, so still shorter than your 115-character answer. $\endgroup$
    – Neil
    Sep 11 at 20:43
9
$\begingroup$

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

chromostereopsis.png

Improve this answer
$\endgroup$
6
  • 1
    $\begingroup$ A possible variant, same characters: w=49;Image[1~RandomInteger~{w,w}#&/@{12~#~w,0,1-16~#~w},Interleaving->0>1]&@DiskMatrix $\endgroup$
    – chyanog
    Sep 10 at 14:36
  • $\begingroup$ +1 super cool :-) $\endgroup$
    – Vitaliy Kaurov
    Sep 10 at 17:13
  • $\begingroup$ @VitaliyKaurov Thanks. I tried my best with constraint of Image output. :) $\endgroup$
    – Silvia
    Sep 10 at 18:41
  • $\begingroup$ @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. :) $\endgroup$
    – Silvia
    Sep 10 at 18:43
  • 1
    $\begingroup$ replace {3,1,2} with 3\[TwoWayRule]1 to get 82 characters. $\endgroup$
    – kglr
    Sep 11 at 7:55
8
$\begingroup$

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 *)

enter image description here

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

(* 80 *)

enter image description here

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

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
Improve this answer
$\endgroup$
1
  • $\begingroup$ +1 RadialGradientImage what a wonderful find, thank you ! $\endgroup$
    – Vitaliy Kaurov
    Sep 11 at 21:53
6
$\begingroup$

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]]

enter image description here

Improve this answer
$\endgroup$
6
$\begingroup$

Just another variation using GaussianMatrix:

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

86 Characters ..

enter image description here

Improve this answer
$\endgroup$
5
$\begingroup$

94 characters:

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

enter image description here

Improve this answer
$\endgroup$
5
$\begingroup$

Shortening Melago's method to 87 characters:

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

enter image description here

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

enter image description here

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

Improve this answer
$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge that you have read and understand our privacy policy and code of conduct.

Not the answer you're looking for? Browse other questions tagged or ask your own question.