3
$\begingroup$

I would like Mathematica to produce for me a matrix $M$, where the entry $M_{ij}$ is a coloured disk with a black numeral in it, representing a billiard ball.

Basically, I want a simplified example based on the following:

enter image description here

(This is in fact an illustration of two orthogonal Latin squares, one in the colours and one in the numbers.)

What I would want instead is for all the purple squares to be replaced with a purple disk having the numeral "2" inside it, all the red squares replaced by a red disk with numeral "3" in it etc.

I want to construct a matrix where each row is a user-specified sequence of correctly coloured and numbered billiard balls. All rows have the same length but there need not be the same number of rows and columns.

I'll be happy for something that lets me input the sequence of numbers row by row, so that I can generate the desired output by lifting entries from a matrix. Right now I can get Mma to produce the correct coloured disks, but I cannot find a way to overlay the numerals inside the disks.

For those perfectionists the colour schemes for the (solid) billiard balls are approximately (in RGB):

  • 1 (Yellow): (255, 221, 51)
  • 2 (Blue): (0, 102, 204)
  • 3 (Red): (204, 0, 0)
  • 4 (Purple): (102, 0, 153)
  • 5 (Orange): (255, 102, 0)
  • 6 (Green): (0, 153, 0)
  • 7 (Burgundy/Maroon): (153, 51, 51)
  • 8 (Black): (0, 0, 0)
Improve this question
$\endgroup$
0

3 Answers 3

Reset to default
13
$\begingroup$

Update:

Modified the ball function so it generates striped balls as well (based on feedback in the comments).

ball[number_Integer, color_, stripedQ_ : False] := Module[{texture}, texture = Graphics[{color , Rectangle @@ If[stripedQ && number != 8, {{0, .2}, {1, .8}}, {{1, 1}, {0, 0}}] , {White, Disk[{.5, .5}, .18]} , Inset[ Style[ToString@number, Black, FontFamily -> "Helvetica", 40, Bold] , {.5, .5}, Center]} , PlotRange -> {{0, 1}, {0, 1}} , Background -> None, ImagePadding -> 0, ImageSize -> 150]; Graphics3D[{{Specularity[White, 100], Texture[texture, "Front"], Sphere[{0, 0, 0}, 1]}} , Lighting -> Automatic , SphericalRegion -> True , ViewPoint -> RandomReal[{-1, 1}] + {0, -5, .5} , Boxed -> False, Axes -> False, ImageSize -> 250]] 
SeedRandom[123]; GraphicsGrid@ Map[ball[#, colors[#], RandomChoice[{True, False}]] & , Table[RandomSample[Range[8]], 3], {2}]

striped

Original version

Just for fun..

ball[number_Integer, color_] := Module[{texture}, texture = Graphics[{color, Rectangle[{0, 0}, {1, 1}] , {White, Disk[{.5, .5}, .18]} , Inset[ Style[ToString@number, Black, FontFamily -> "Helvetica", 40, Bold] , {.5, .5}, Center]} , PlotRange -> {{0, 1}, {0, 1}} , Background -> None, ImagePadding -> 0, ImageSize -> 150]; Graphics3D[{{Specularity[White, 100], Texture[texture, "Front"], Sphere[{0, 0, 0}, 1]}} , Lighting -> Automatic , SphericalRegion -> True , ViewPoint -> RandomReal[{-1, 1}] + {0, -5, .5} , Boxed -> False, Axes -> False, ImageSize -> 250]] colors = <| 1 -> RGBColor[1, 0.80, 0],(*yellow*) 2 -> RGBColor[0, 0.40, 0.80],(*blue*) 3 -> RGBColor[0.80, 0, 0],(*red*) 4 -> RGBColor[0.40, 0, 0.60],(*violet*) 5 -> RGBColor[1, 0.40, 0],(*orange*) 6 -> RGBColor[0, 0.60, 0],(*green*) 7 -> RGBColor[0.60, 0, 0],(*maroon*) 8 -> RGBColor[0.01, 0.01, 0.01, .7] (*black*)|>; SeedRandom[1]; GraphicsGrid@ Map[ball[#, colors[#]] & , Table[RandomSample[Range[8]], 3], {2}]

enter image description here

Improve this answer
$\endgroup$
5
  • $\begingroup$ Numbers at back of balls are flipped ;-) $\endgroup$ Commented Oct 5 at 11:52
  • $\begingroup$ Thank you @azerbajdzan, I'll look into it. $\endgroup$ Commented Oct 5 at 15:40
  • 1
    $\begingroup$ I think for OP's purpose it is enough. $\endgroup$ Commented Oct 5 at 15:42
  • $\begingroup$ @azerbajdzan yes more than enough. Very happy with this awesome outcome. There a comment below about including the white ball, to which I assigned the numeral 0. I suppose if you really want to get fancy one could also construct striped balls for 1-7 (since the title has changed from my original to explicitly mention billiard balls) but I'm happy to accept as is. $\endgroup$ Commented Oct 6 at 0:45
  • $\begingroup$ @ZeroTheHero Glad it helped! Please see the update related to the striped balls. $\endgroup$ Commented Oct 6 at 9:06
5
$\begingroup$ 
$Version (* "14.3.0 for Mac OS X ARM (64-bit) (July 8, 2025)" *) Clear["Global`*"] colors = { {yellow, 1, {255, 221, 51}}, {blue, 2, {0, 102, 204}}, {red, 3, {204, 0, 0}}, {purple, 4, {102, 0, 153}}, {orange, 5, {255, 102, 0}}, {green, 6, {0, 153, 0}}, {maroon, 7, {153, 51, 51}}, {black, 8, {0, 0, 0}}}; (#1 := Graphics[{RGBColor[#3/255], Disk[{0, 0}, 1/8], White, Disk[{0, 0}, 1/28], Black, Text[Style[#2, 24]]}]) & @@@ colors; Grid[RandomChoice[colors[[All, 1]], {6, 4}], ItemSize -> 6]

enter image description here

Grid[{{red, yellow, blue}, {maroon, black, yellow}}, ItemSize -> 6]

enter image description here

EDIT: Using numbers

Grid[mat = RandomChoice[Range[8], {2, 4}]]

enter image description here

Grid[Map[colors[[#, 1]] &, mat, {2}], ItemSize -> 6]

enter image description here

Improve this answer
$\endgroup$
1
  • $\begingroup$ This is really nice and exactly what I had in mind, although I must admit the solution of @vindobona makes for an incredibly appealing presentation. $\endgroup$ Commented Oct 5 at 13:50
4
$\begingroup$ 
colormap = Association["Yellow" -> RGBColor[{255, 221, 51}/255], "Blue" -> RGBColor[{0, 102, 204}/255], "Red" -> RGBColor[{204, 0, 0}/255], "Purple" -> RGBColor[{102, 0, 153}/255], "Orange" -> RGBColor[{255, 102, 0}/255], "Green" -> RGBColor[{0, 153, 0}/255], "Burgundy/Maroon" -> RGBColor[{153, 51, 51}/255], "Black" -> RGBColor[{0, 0, 0}/255], "White" -> RGBColor[{255, 255, 255}/255]]; number2color = Association[1 -> "White", 2 -> "Purple", 3 -> "Red", 4 -> "Yellow", 5 -> "Green"]; m1 = {{1, 2, 3, 4, 5}, {2, 3, 4, 5, 1}, {3, 4, 5, 1, 2}, {4, 5, 1, 2, 3}, {5, 1, 2, 3, 4}}; m2 = {{1, 2, 3, 4, 5}, {3, 4, 5, 1, 2}, {5, 1, 2, 3, 4}, {2, 3, 4, 5, 1}, {4, 5, 1, 2, 3}} /. number2color; m = MapThread[List, {m1, m2}, 2]; draw[number_, color_] := Graphics[{EdgeForm[Black], Text[Style[number, 50]], colormap@color, Annulus[{0, 0}, {.5, 1}]}] Apply[draw, m, {2}] // GraphicsGrid

enter image description here

  • Or RadialGradientFilling to get another shading.
Clear[draw]; draw[number_, color_] := Graphics[{{RadialGradientFilling[{0, .85, 1} -> {White, colormap@color, LightGray}, {.5, .5}], Disk[{0, 0}, 1]}, {Text[Style[number, 50]]}}] GraphicsGrid[Apply[draw, m, {2}], Spacings -> 0]

enter image description here

Improve this answer
$\endgroup$
2
  • $\begingroup$ A better gradient I think: Graphics[{{RadialGradientFilling[{0, 0.3, 0.31, 1} -> {White, Lighter@Lighter@Darker@White, colormap@color, Darker@colormap@color}, {.5, .5}], Disk[{0, 0}, 1]}, {Text[Style[number, Large]]}}] $\endgroup$ Commented Oct 6 at 10:28
  • $\begingroup$ @azerbajdzan Thanks. I test a similar approach, but I want to keep the white instead of light gray. $\endgroup$ Commented Oct 6 at 10:40

Start asking to get answers

Find the answer to your question by asking.

Ask question

Explore related questions

See similar questions with these tags.