tl;dr
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:
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]&
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]&
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
(box2=(u//toIndex //to3D) /.{x_,y_,z_}-> {z, y, -x+9} ) //Map[toCube] //Graphics3D
(box3=(heart //toIndex//to3D) /.{x_,y_,z_}-> {x, y, z} ) //Map[toCube] //Graphics3D
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
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
:
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)