Mathematica creates a huge eps file [duplicate]

Question

I use the following code (based on the responses in my recent relevant questions) in order to generate randomly distributed unidirectional cylinders in a cylinder of elliptical cross section.

findPoints = 
  Compile[{{n, _Integer}, {low, _Real}, {high, _Real}, {minD, _Real}},
    Block[{data = RandomReal[{low, high}, {1, 2}], k = 1, rv, temp}, 
    While[k < n, rv = RandomReal[{low, high}, 2];
     temp = Transpose[Transpose[data] - rv];
     If[Min[Sqrt[(#.#)] & /@ temp] > minD, data = Join[data, {rv}];
      k++;];];
    data]];

npts = 150;
r = 0.03;
minD = 2.2 r;
low = 0;
high = 1;

ep = With[{a = 2/5, b = 1/2}, 
   BoundaryDiscretizeRegion@
    ParametricRegion[(low + high) {1, 1}/2 + 
      c ({a Cos[t], b Sin[t]} + 
         r Normalize[Cross[D[{a Cos[t], b Sin[t]}, t]]]), {{c, 0, 
       1}, {t, 0, 2 \[Pi]}}]];

SeedRandom[159];
pts = Select[findPoints[npts, low, high, minD], RegionMember[ep, #] &];
g2d = Graphics[{FaceForm@GrayLevel[0.8], 
    EdgeForm@
     Directive[Thickness[0.004], 
      Black], {GrayLevel[0.6], Disk[#, r]} & /@ pts}, 
   PlotRange -> {{low, high}, {low, high}}, 
   Background -> GrayLevel[0.8]];

mask = BoundaryDiscretizeRegion[#, {{-1, 1}, {-1, 1}}, 
     MaxCellMeasure -> {1 -> .02}] &@
   BoundaryDiscretizeRegion[Disk[{0.5, 0.5}, {0.4, 0.5}]];
r2d = DiscretizeGraphics[g2d, MaxCellMeasure -> {1 -> .01}, 
   PlotRange -> All];
inside = RegionIntersection[r2d, mask];

edge = DiscretizeRegion@*Line@*Intersection @@ 
   Round[{Sort /@ 
      MeshPrimitives[RegionIntersection[r2d, mask], 1][[;; , 1]], 
     Sort /@ MeshPrimitives[RegionDifference[r2d, mask], 1][[;; , 
        1]]}, .0001];
points = DiscretizeRegion@*Point@*Intersection @@ 
   Round[{MeshPrimitives[RegionDifference[r2d, mask], 0][[;; , 1]], 
     MeshPrimitives[RegionDifference[mask, r2d], 0][[;; , 1]]}, .0001];

regionProduct[reg_, join_: True, y1_: 0, y2_: 1] := 
  Module[{n = MeshCellCount[reg, 0]}, 
   MeshRegion[
    Join @@ (ArrayFlatten@{{#[[;; , ;; 1]], #2, #[[;; , 2 ;;]]}} &[
         MeshCoordinates@reg, #] & /@ {y1, y2}), {MeshCells[reg, _], 
     MeshCells[reg, _] /. p : {__Integer} :> p + n, 
     If[join, 
      MeshCells[
        reg, _] /. {(Polygon | Line)[
          p_] :> (Polygon@Join[#, Reverse[#, 2] + n, 2] &@
           Partition[p, 2, 1, 1]), 
        Point[p_] :> Line@{p, p + n}}, ## &[]]}]];
mask3d = regionProduct@mask;
inside3d = regionProduct[inside, False];
edge3d = regionProduct@edge;
points3d = regionProduct@points;

toGC[reg_, dim_] := 
  GraphicsComplex[MeshCoordinates@reg, MeshCells[reg, dim]];

Graphics3D[{FaceForm@GrayLevel[0.8], toGC[inside3d, 2], EdgeForm[], 
  toGC[edge3d, 2], toGC[points3d, 1], Lighter@Gray, 
  GeometricTransformation[toGC[mask3d, 2], 
   ScalingTransform[0.999 {1, 1, 1}, RegionCentroid@mask3d]]}, 
 Lighting -> "Neutral", Boxed -> False]

Graphics3D[{FaceForm@GrayLevel[0.8], 
  toGC[regionProduct[RegionBoundary@inside, False], 1], EdgeForm[], 
  toGC[regionProduct@inside, 2], toGC[edge3d, 2], toGC[points3d, 1], 
  Gray, Opacity[0.11], 
  GeometricTransformation[toGC[mask3d, 2], 
   ScalingTransform[0.999 {1, 1, 1} #, RegionCentroid@mask3d] & /@ 
    Range[0, 1, 0.01]]}, Lighting -> "Neutral", Boxed -> False, 
 BaseStyle -> {RenderingOptions -> {"DepthPeelingLayers" -> 100}}]

Mathematica freezes for five minutes when it is asked to export these two graphics as .eps and produces (the second image for example) a file of 406 Mb.

(Same time behavior for other formats.)

Am I doing something wrong?

Any ideas for workaround? I need this picture for publication.

$Version

10.3.0 for Linux x86 (64-bit) (October 9, 2015)