18

enter image description here

This picture shown bellow has three shapes with different view angle (I ♥ U). How to do this type of model? A few tries:

With[{p=Position[ImageData[Binarize[Rasterize[#, ImageSize -> 10]]], 0]},
    Graphics3D[Cuboid /@ PadRight[p, {Length@p, 3}, 0]]
   ] & /@ {"I", "♥", "U"}

enter image description here

J. M.'s missing motivation
  • 124,525
  • 11
  • 401
  • 574
matrix42
  • 6,996
  • 2
  • 26
  • 62
  • 2
    Take a look at Michael Trott´s blog entry here: (esp. the "superman solid"): http://blog.wolfram.com/2013/08/15/even-more-formulas-for-everything-from-filled-algebraic-curves-to-the-twitter-bird-the-american-flag-chocolate-easter-bunnies-and-the-superman-solid/ – Yves Klett Jan 26 '16 at 09:23
  • 1
    Related: http://mathematica.stackexchange.com/q/701/5 – rm -rf Jan 26 '16 at 15:53

1 Answers1

20

tl;dr enter image description here

Playing with your code I found that using Rasterize is a mayor pain in the behind because of various reasons (RasterSize is, at least for me, not working as advertised in the documentation; I found no easy way to remove padding around letters and get a nice $n \times n$ representation of each letter, get each letter the appropriate size, issues with different fonts etc.)

So instead I googled for a 8-bit letter generator and created letters of my own. A bit of copy-paste and string-manipulation in Mathematica and I got the following letter representation:

i = {{1,1,1,1,1,1,1,1},
     {0,0,0,1,1,0,0,0},
     {0,0,0,1,1,0,0,0},
     {0,0,0,1,1,0,0,0},
     {0,0,0,1,1,0,0,0},
     {0,0,0,1,1,0,0,0},
     {0,0,0,1,1,0,0,0},
     {1,1,1,1,1,1,1,1}}

u = {{1,1,1,0,0,1,1,1},
     {0,1,0,0,0,1,1,0},
     {0,1,0,0,0,1,1,0},
     {0,1,0,0,0,1,1,0},
     {0,1,0,0,0,1,1,0},
     {0,1,0,0,0,1,1,0},
     {0,1,1,0,0,1,1,0},
     {0,0,1,1,1,1,0,0}}

and (with some artistic freedom):

h = {{0,0,1,0,0,0,1,0},
     {0,1,1,1,0,1,1,0},
     {1,1,1,1,1,1,1,1},
     {0,1,1,1,1,1,1,1},
     {0,0,1,1,1,1,1,1},
     {0,0,0,1,1,1,1,0},
     {0,0,0,0,1,1,1,0},
     {0,0,0,0,0,1,0,0}}

Helper functions:

  1. The following function transforms a matrix of zeros and ones into positions where the matrix contains a one

    toIndex[matrix_]:= matrix 
                       //MapIndexed[If[#1==1,#2, Nothing[] ]&, #, {2}]& 
                       //Flatten[#,1]&
    
  2. This function transforms a list of form {{x1, y1},...{x8, y8}} into {{x1, y1, z1}, {x1, y1, z2}} ... {x8, y8, z8}

    to3D[pos_]:= Table[pos /. {x_,y_}-> {x,y,z}, {z, 1, 8}] //Flatten[#,1]&
    
  3. A wrapper for Cuboid to accept the center of the unit cube instead of the lower left corner as parameter

    toCube[center_]:= Cuboid[center-{0.5, 0.5, 0.5}]
    

Now lets create some graphics and save the position definitions in some symbols box1, box2 and box3 :

(box1=(i//toIndex//to3D) /.{x_,y_,z_}-> {y, z, x} ) //Map[toCube] //Graphics3D

i

(box2=(u//toIndex //to3D) /.{x_,y_,z_}-> {z, y, -x+9} ) //Map[toCube] //Graphics3D

u

(box3=(heart //toIndex//to3D) /.{x_,y_,z_}-> {x, y, z} ) //Map[toCube] //Graphics3D

h

Note the coordinate transformation via replacement rules to get the right orientation

Finally we can assemble the whole thing via intersection:

Intersection[box1, box2, box3] //Map[toCube] //Graphics3D

perspective

i2

u2

h2

Edit:

As one can see my solution does not result in the kind of "random box-cloud" that the OP showed in his question. This is due to the intersection method that was used to "sculpt" the geometry. Here is an improved version that amends this:

The following function neighboursQ tests wether a block has neighbours. A neighbour is a block that shares one axis with the block in question. Only when it has neighbouring blocks to all sides can it be deleted without compromising the projection.

neighboursQ[list_][{x_,y_,z_}]:= {
                                   Cases[list, {_,y,z}],
                                   Cases[list, {x,_,z}],
                                   Cases[list, {x,y,_}]
                                 } //Map[Length] 
                                   //Subtract[#, 1]& 
                                   //MatchQ[{___,0,___}] 
                                   //Not

Let's test on two simple examples:

testbox = Table[{i, j, k}, {i, 1, 3}, {j, 1, 3}, {k, 1, 3}]  //Flatten[#,2]&
testbox2= DeleteCases[testcube, {2,1,1}|{3,1,1}|{1,1,2}]

testbox is a full $9 \times 9$ box so that we expect each block to have neighbours. We can confirm that via testbox //Map[neighboursQ[testbox]] which yields a whole bunch of True. Now on to testbox2:

testbox2

 neighboursQ[testcube2][{1,1,1}] (*False*)
 neighboursQ[testcube2][{1,1,3}] (*True*)

neighboursQ works as we saw in the examples so we just have to repeatedly (and randomly) apply it our blocks. I wrote the following function to do just that. (It gets applied 500 times via Nest so that it has a high chance to have found any remaining block with neighbours, your milage may vary depending on number of blocks to start with)

deleteDuplicates[list_]:= Nest[With[{this=RandomChoice@#},
If[neighboursQ[#][this], DeleteCases[#,this], #]]&, list, 500]

Some other random examples:

Grid[{{x,x},{x,x}}] 
/. x:>(Intersection[box1, box2, box3]  //deleteDuplicates //Map[toCube] //Graphics3D)

enter image description here

Sascha
  • 8,459
  • 2
  • 32
  • 66