Lichtenberg figures (https://en.wikipedia.org/wiki/Lichtenberg_figure) can be generated by irradiating e.g. PMMA (i.e. Poly(methyl methacrylate), “acrylic glass”) with a high energy electron beam. This way electrons are implanted inside the material - which is an insulator. By a controlled discharge very aesthetic tree structures consisting of tracks from the electrical current can be generated. (This is just one method.)
​
It is fun trying to imitate this using Mathematica! The idea is simple:
◼
  • define a MeshRegion (this is all you need as input);
    • ◼
  • convert it to a Graph (with preserved VertexCoordinates and EdgeWeight);
    • ◼
  • use FindShortestPath to a specific “starting point”.

    • Generating Lichtenberg like figure from MeshRegion in 2D or 3D:

    In[]:=
    meshRegion2Lichtenberg[mr_MeshRegion]:=Module[{pts,conns,coord2index,index2coord,geomStart,startPt,startPtIndex,edgeWeights,ue,numPoints,graph,shortestPath,lines},​​pts=MeshPrimitives[mr,0];​​pts=Chop@@@pts;(*points*)​​numPoints=Length[pts];​​​​conns=Chop@@@MeshPrimitives[mr,1];(*connections*)​​​​coord2index=MapIndexed[#1First[#2]&,pts];​​index2coord=Rule[#2,#1]&@@@coord2index;​​​​(*geometricstartpoint:middle/bottom*)​​geomStart=Append[Mean/@Most[#],Min[Last[#]]]&@CoordinateBounds[pts];​​(*meshpointwhichisclosestto"geomStart"forstart:*)​​startPt=First@TakeSmallestBy[pts,EuclideanDistance[geomStart,#]&,1];​​startPtIndex=startPt/.coord2index;​​​​edgeWeights=N[EuclideanDistance@@@conns];​​ue=UndirectedEdge@@@(conns/.coord2index);​​​​graph=Graph[Range[numPoints],ue,VertexCoordinatespts,EdgeWeightedgeWeights];​​​​shortestPath=FindShortestPath[graph,startPtIndex];​​lines=(Partition[#,2,1]&/@(shortestPath/@Complement[Range[numPoints],{startPtIndex}]))/.index2coord;​​(*statistics:"how many times is the line segment `used`:"*)​​Tally[Flatten[lines,1]]​​]
    As mentioned there is a simple mapping from a MeshRegion to the Lichtenberg graphics:
    In[]:=
    (*exampleregions:*)​​reg1=BooleanRegion[And,{Disk[{0,.5},1],Disk[{-.5,-.2},1],Disk[{.5,-.2},1]}];​​mr1=DelaunayMesh[RandomPoint[reg1,3000]];​​reg2=ParametricRegion[{{s,(1+t)s^2-t},-1≤s≤1&&0≤t≤1},{s,t}];​​mr2=DiscretizeRegion[reg2,MaxCellMeasure{"Length".05}];​​reg3=BooleanRegion[Xor,{DiskSegment[{0,0},2,{-.3,Pi+.3}],BooleanRegion[Or,{Disk[{-.5,.9},.35],Disk[{.4,.5},.3]}]}];​​mr3=DiscretizeRegion[reg3,MaxCellMeasure{"Length".1}];​​(*regiontakenfromDocumentation/ParametricRegion/Scope:*)​​constraint=-3/4+(5*x-20*x^3+16*x^5)^2-(5*x-20*x^3+16*x^5)*(1-8*y^2+8*y^4)+(1-8*y^2+8*y^4)^2≤0;​​mr4=DiscretizeRegion[ImplicitRegion[constraint,{x,y}],MaxCellMeasure{"Length".05}];​​​​regions={mr1,mr2,mr3,mr4};
    In[]:=
    lichtenbergs=ParallelMap[(wlSegs=meshRegion2Lichtenberg[#];​​Graphics[{{Black,Thickness[Sqrt[#2]/2500],Line[#1]}&@@@wlSegs}])&,regions];
    In[]:=
    GraphicsGrid[Transpose[{regions,lichtenbergs}],FrameAll,ImageSize600]
    Out[]=

    Single steps of function meshRegion2Lichtenberg for exporting animation:

    In[]:=
    mr=DiscretizeRegion[reg3,MaxCellMeasure{"Length".07}];​​pts=MeshPrimitives[mr,0];​​pts=Chop@@@pts;​​numPoints=Length[pts];
    In[]:=
    conns=Chop@@@MeshPrimitives[mr,1];​​​​coord2index=MapIndexed[#1First[#2]&,pts];​​index2coord=Rule[#2,#1]&@@@coord2index;​​​​geomStart=Append[Mean/@Most[#],Min[Last[#]]]&@CoordinateBounds[pts];​​startPt=First@TakeSmallestBy[pts,EuclideanDistance[geomStart,#]&,1];​​startPtIndex=startPt/.coord2index;​​​​edgeWeights=N[EuclideanDistance@@@conns];​​ue=UndirectedEdge@@@(conns/.coord2index);
    In[]:=
    graph=Graph[Range[numPoints],ue,VertexCoordinatespts,EdgeWeightedgeWeights];​​shortestPath=FindShortestPath[graph,startPtIndex];

    Example in 3D:

    Due to the universally designed WL functions - it works in 3D without any change of code:

    CITE THIS NOTEBOOK

    Computational Lichtenberg figures​
    by Henrik Schachner​
    Wolfram Community, STAFF PICKS, 2017
    ​https://community.wolfram.com/groups/-/m/t/1065956