Creating the Yin Yang symbol with minimal code

Question

The following code creates the Yin Yang symbol

Graphics[{Black, Circle[{0, 0}, 1], White, 
   DiskSegment[{0, 0}, 1, {1/2 \[Pi], 3/2 \[Pi]}],
   Black, DiskSegment[{0, 0}, 1, {3/2 \[Pi], 5/2 \[Pi]}], White, 
   Disk[{0, 0.5}, 0.5],
   Black, Disk[{0, -0.5}, 0.5], Black, Disk[{0, 0.5}, 0.125],
   White, Disk[{0, -0.5}, 0.125]
   }] // Show

Knowing that 'there is always someone who can do things with less code', I wondered what the optimal way is, in Mathematica, to create the Yin Yang symbol.

Not really an urgent question to a real problem, but a challenge, a puzzle, if you like. I hope these kind of questions can still be asked here.

Answer 1

d = {#, 0} ~ Disk ~ ##2 &; 

Graphics@{d[4, 8, {0, π}], 8~d~4, {White, 0~d~4, d@8}, d@0, Circle @@ 4~d~8}

StringLength @ "d={#,0}~Disk~##2&
Graphics@{d[4,8,{0,π}],8~d~4,White,0~d~4,d@8},d@0,Circle@@4~d~8}"

83

We can get the rotated version at a cost of three additional characters: Replace {#, 0} with {0,#} and {0, π} with {3, 5} π/2 to get

Answer 2

Unicode:

\:262F
(*    ☯    *)

For post-processing at higher resolution, we can rasterize this character to arbitrary pixel counts:

Rasterize[\:262F, RasterSize -> 1000] // ImageCrop

Answer 3

I think the code in the OP is nice and concise, and generates a good graphic. But if brevity is the goal, you can turn to the Knowledgebase via

Graphics[Interpreter["Character"]["yin yang symbol"]["Glyph"]]

Longer code, but gives a nice football shape:

Plot[{Sin @ x, Sin[2 * x] / 2, -Sin[x]},
    {x, 0, Pi},
    Filling -> {1 -> {{2}, Black}, 3 -> {2, White}},
    Axes -> False,
    PlotStyle -> {None, Black, Black},
    Epilog -> {{White,Disk[{(2 \[Pi])/3.,1/3},0.1]},{Black,Disk[{\[Pi]/3.,-(1/3)},0.1]}}
]

Answer 4

Not shorter, just different

RegionPlot[{
  x^2 + y^2 < 7, 
  x > Sin[y] && x^2 + y^2 < 7, 
  (x - .2)^2 + (y + 1.5)^2 < .2, 
  (x + .2)^2 + (y - 1.5)^2 < .2},
 {x, -3, 3}, {y, -3, 3},
 PlotStyle -> {White, Black, White, Black}, 
 BoundaryStyle -> Black, Frame -> False]

Answer 5

As a plot with Filling:

Plot[{-Sqrt[1 - (x - Sign@x)^2] Sign@x, Sqrt[4 - x^2], -Sqrt[4 - x^2]}
 , {x, -2, 2}, Filling -> {1 -> {3}}, AspectRatio -> 1, 
 PlotRange -> {{-3, 3}, {-3, 3}}, FillingStyle -> Black, 
 PlotStyle -> Black, Axes -> False, Exclusions -> None, 
 Epilog -> {Disk[{1, 0}, .3], White, Disk[{-1, 0}, .3]}]

With region operations, and golfed:

d = Disk; c = {1, 0}; Graphics@{Circle[0 c, 2], 
 DiscretizeRegion@RegionDifference[RegionUnion[d[0 c, 2, {0, π}], d[c, 1]], 
    d[-c, 1]], d[-c, .2], White, d[c, .2]}

Answer 6

l = Line /@ Transpose @ Map[{#, ({0, 1} + #)/2, ({0, -1} + {-1, 1} #)/2} &] @
     CirclePoints[{1, -π/2}, 50][[;; 26]];

Graphics@{Circle[], FilledCurve @ l, Disk[{0, 1/2}, 1/8], White, Disk[{0, -1/2}, 1/8]}

Answer 7

From this post in Chinese community:

With[{r = Sqrt[x^2 + y^2], θ = ArcTan[x, y]}, 
 RegionPlot[(Cos[θ - r] - Sin[θ]) 
            (r^4 - 2 r^2 Cos[2 θ + 24/10] + 9/10) + (62/100 r)^1000 < 0, 
        {x, -2, 2}, {y, -2, 2}, PlotPoints -> 67]]