(*:Mathematica Version: 2.1 *) (*:Package Version: 1.2 *) (*:Context: Graphics`GraphicsOperations *) (*:Title: GraphicsOperations *) (*:Author: Jeff Adams *) (*:Summary: This package defines functions useful for transforming graphics primitives. *) (* :Copyright: Copyright 1992-1993, Wolfram Research, Inc.*) (*:Keywords: graphics primitives, translation, rotation, scaling *) (*:Requirements: none. *) (*:Sources: "Graphics Gems", edited by Andrew S. Glassner, Academic Press, Inc., 1990. specifically, articles: "An Efficient Ray-Polygon Intersection", "Fast Ray-Polygon Intersection", "Fast Ray-Box Intersection" *) (*:History: Version 1.0, Jeff Adams, September 1992. Version 1.1, Jeff Adams, March 1993. - Added the ability to use the graphics functions (except SliceGraphics) on graphics primitives directly, not requiring them to be wrapped in Graphics, Graphics3D, etc. - Fixed unreported bug in BoundingRegion[Point[_]]. Version 1.2, Jeff Adams, April 1993. - Eliminated possibilites of getting negative radii with Circle and Disk primitives. *) (*:Limitations: The transformation functions contained in this package do not work with Scaled coordinates. RotateGraphics[] rotates only the coordinates and the begin and end angles of Circle[] and Disk[] primitives, but the semi-axes of the arcs are not changed. You do not notice this limitation when the radii are the same, i.e., you only notice this limitation with ellipses. Unlike DensityGraphics and Raster, there is currently no option for extracting or removing a z-range from ContourGraphics using TakeGraphics and DropGraphics. *) (*:Discussion: In most cases, with the setting of ModifyGraphics->True, the RegionTest option is not even used since primitives that can be split will be split exactly at the boundary of the region. Since the occurrence of one Line[] graphics primitive is very common in 2D plots to describe the entire curve, the Line[] primitive will at least be chopped up into separate Line[] primitives, though using the same list of coordinate points, when crossing a region even with the option ModifyGraphics->False. ScaleGraphics[] acts only on the coordinates of any Text[] primitives. DropGraphics[], TakeGraphics[] and therefore SliceGraphics[] use the coordinates of Text[] primitives to determine its region of existence. This means that only the origin is tested with regard to whether the primitive is within or outside a region. *) (*:Warnings: *) (*:Examples: graph = Graphics3D[Plot3D[Sin[x y],{x,-3,3},{y,-3,3}]]; Show[ScaleGraphics[graph,{.1,.2,.3}], BoxRatios->Automatic] Show[RotateGraphics[graph,{Pi/4,Pi/2,Pi/7}],BoxRatios->Automatic] Show[TranslateGraphics[graph,{10,100,-50}]] Show[TakeGraphics[graph,{{-1,-1},{2,2}}], Axes->True] Show[TakeGraphics[graph,{{-1,-1},{2,2}}, ModifyGraphics->True], Axes->True] Show[DropGraphics[graph,{{-1,-1},{2,2}}], Axes->True] graph = Plot[Sin[x],{x,0,3}] Show[ SliceGraphics[graph, 6, Axis->{1,0,0}]] graph = Plot3D[Sin[x y],{x,-3,3},{y,-3,3},PlotPoints->15] Show[ SliceGraphics[graph,2, Axis->{1,0,0}]] g1 = Plot[t,{t,0,Pi}]; Show[ TransformGraphics[ g1, Sin[#]& ] ] g1 = Plot[ Sin[t],{t,0,Pi}]; Show[ SkewGraphics[g1, {{1,2},{0,1}}]] <Inset, ModifyGraphics->False} Options[ RotateGraphics] = {TextRotated->False} Options[ SliceGraphics] = {Options[TakeGraphics], Axis -> {1,0,0}, SliceSpacing->Automatic, SliceRatios->Automatic} (************************************************************************) (* Auxiliary private functions *) (************************************************************************) (* Define a better NumberQ *) numberQ[x_] := NumberQ[N[x]] (* Boolean functions for 2D and 3D determining whether a point is within a rectangular region. *) within[{x_,y_},{{xmin_,ymin_,___},{xmax_,ymax_,___}}] := ((xmin <= x <= xmax) && (ymin <= y <= ymax)) within[{x_,y_,z_},{{xmin_,ymin_,zmin_:-Infinity}, {xmax_,ymax_,zmax_:Infinity}}] := ((xmin <= x <= xmax) && (ymin <= y <= ymax) && (zmin <= z <= zmax)) within[z_,{{xmin_,ymin_,zmin_:-Infinity}, {xmax_,ymax_,zmax_:Infinity}}] := zmin <= z <= zmax (* Returns the smallest rectangular region (2D or 3D) enclosing the list of points poly. Used essentially for polygons. *) boundingBox[poly_] := {Min /@ #, Max /@ #}&[Transpose[poly]] (* A simple function for triangulating polygons. It is fine for 3 and 4 sided polygons, but you may want to change the code for higher order polygons. It works fine for regular convex polygons though. *) triangulate[d_List] := If[Length[d] > 3, If[Length[d] > 4, basictriangulate[d], {Drop[d,1],Drop[d,{3}]}], {d}] basictriangulate[d_List] := With[{cntr = Plus @@ d/Length[d]}, Map[Join[#,{cntr}]&, Join[ Partition[d,2,1], {{First[d],Last[d]}}]]] (* A tool I use to visually see the region I am extracting or dropping *) GraphicBox[{{xmin_,ymin_},{xmax_,ymax_}}] := Line[{{xmin,ymin},{xmin,ymax},{xmax,ymax},{xmax,ymin},{xmin,ymin}}] GraphicBox[{{xmin_,ymin_,zmin_},{xmax_,ymax_,zmax_}}] := Module[{bottom, top}, bottom = {{xmin,ymin,zmin},{xmin,ymax,zmin}, {xmax,ymax,zmin},{xmax,ymin,zmin}}; top = {{xmin,ymin,zmax},{xmin,ymax,zmax}, {xmax,ymax,zmax},{xmax,ymin,zmax}}; Line /@ Join[Partition[bottom,2,1],{{Last[bottom],First[bottom]}}, Transpose[{bottom, top}], Partition[top,2,1],{{Last[top],First[top]}}] ] (* I use these global variables to store the current list of region points since all primitives, specifically polygons, will use this same list in one call of TakeGraphics or DropGraphics. Essentially a time saver. *) $regionPts2D = {} $regionPts3D = {} (* This global variable is solely used with DropGraphics on Polygon primitives to aid in the case when the region is entirely within the polygon and we want to be able to punch a hole inside the polygon. $Intersect is used to tell us whether there has been at least one intersection of the polygon and region, and if $Intersect has been set to True after testing each polygon segment, then it cannot be possible that we want to punch a hole through the polygon. *) $Intersect = False (* This function creates the lists of region points and stores them in the global variables $regionPts2D and $regionPts3D to be used by all polygons in one call to TakeGraphics or DropGraphics. *) makeRegionPts[{{xmin_,ymin_,zmin_:-Infinity}, {xmax_,ymax_,zmax_:Infinity}}] := Module[{bottom, top}, $regionPts2D = {{xmin,ymin},{xmin,ymax},{xmax,ymax},{xmax,ymin}}; bottom = {{xmin,ymin,zmin},{xmin,ymax,zmin}, {xmax,ymax,zmin},{xmax,ymin,zmin}}; top = {{xmin,ymin,zmax},{xmin,ymax,zmax}, {xmax,ymax,zmax},{xmax,ymin,zmax}}; $regionPts3D = Join[Partition[bottom,2,1],{{Last[bottom],First[bottom]}}, Transpose[{bottom, top}], Partition[top,2,1],{{Last[top],First[top]}}] ] (* The 2D and 3D functions which return all region points that exist inside the list of points d, (polygon specified by d). Obviously, the 3D version is more complicated because you must deal with the intersection of the edges of the region cube with the polygon, and not just whether the four corners of the rectangle are in the polygon as the 2D case requires. *) regionPts[d:{{_,_}...}] := Module[{bbox = boundingBox[d], triang = triangulate[d]}, Select[$regionPts2D, (within[#,bbox] && Or @@ Map[Function[x,PointInTriangleQ[#,x]], triang])&] ] regionPts[d:{{_,_,_}...}] := Module[{bbox = boundingBox[d], trbox, rays, triang = triangulate[d]}, trbox = Transpose[bbox]; rays = Select[$regionPts3D, !onOneSide[#,trbox]&]; If[rays == {}, Return[{}]]; rays = Map[adjustPoints[#,bbox]&, rays,{2}]; rays = (Map[Function[x, RayTriIntersect[#,x,bbox]], triang])& /@ rays; rays = DeleteCases[#,$Failed]& /@ rays; Flatten[Select[rays, # =!= {}&],1] ] (* This function is used in the 3D regionPts[] case to convert all elements which are -Infinity or Infinity to numbers just outside the bounding box of the polygon. *) adjustPoints[pt_,{min_,max_}] := MapThread[If[!numberQ[#1],Min[Max[#1,#2]-1,#3]+1,#1]&,{pt,min,max}] (* This function is used within simplifyVals to break up the points in list into sublists using the element {} to signify the begin/end of a sublist. *) parseList[list_, element_] := If[element =!= {}, If[First[element] == {}, If[element[[2]] == {}, Append[list,{}], If[And @@ (VectorQ /@ element[[2]]), Join[list,{{element[[2]]},{}}], Join[ Insert[list,element[[2,1]],{-1,-1}], {{},{element[[2,2]]}}] ] ], Insert[list,element,{-1,-1}] ], Append[list,{}] ] (* This function is used within simplifyVals to recombine any sublists whose begin and end elements match, thus returning the equivalent joined list instead of two separate lists. *) joinLists[lists_, onelist_] := If[Last[Last[lists]] === First[onelist], Append[Drop[lists,-1],Join[Last[lists],Rest[onelist]]], Insert[lists,onelist,-1]] (* This function is called for both Line and Polygon primitives to return a list of subsegments of the original points after extracting or removing some of them. *) simplifyVals[list_] := Module[{vals,ends}, vals = Select[ Fold[ parseList, {{}}, list], Length[#]>0&]; ends = Last[#][[2]]& /@ vals; vals = Transpose[#][[1]]& /@ vals; vals = MapThread[Join[#1,{#2}]&,{vals,ends}]; If[ Length[vals] > 1, vals = Fold[joinLists, {First[vals]}, Rest[vals]]; If[Length[vals] > 1, If[First[First[vals]] === Last[Last[vals]], vals = Append[Drop[RotateLeft[vals],-2], Join[Last[vals],Rest[First[vals]]]] ] ] ]; vals ] (* This function takes the current list of region points within a polygon, and breaks the list up into sublists where all elements in a sublist are grouped by the criteria of having at least one coordinate matching. This essentially breaks up the region points based on whether they are next to each other in the rectangular box (2D) or in the cube (3D). This is necessary for determining where to correctly insert the region points into the list of points describing the polygon. *) sepRList[list_, element_] := Module[{search = Last[list]}, If[Length[search] == 0, Return[Append[list,{element}]]]; If[ Or @@ MapThread[(#1 == #2)&, {Last[search],element}], Insert[list,element,{-1,-1}], Append[list,{element}]] ] (* This function actually does the inserting of region points into the list of polygon points. Each sublist of region points (see desciption of the function above) is inserted by matching a polygon point with the first element of the region points list and matching a polygon point with the last element of the region points. These begin and end points determine where to insert the region points into the list of points describing the polygon. *) addRpts[list_, elements_] := Module[{beginr,endr,pos, ele = elements}, beginr = First[ele]; endr = Last[ele]; beginr = Select[MapIndexed[List,list], (Or @@ MapThread[(#1 == #2)&, {#[[1]],beginr}])&]; endr = Select[MapIndexed[List,list], (Or @@ MapThread[(#1 == #2)&, {#[[1]],endr}])&]; If[Length[beginr] == 0 || Length[endr] == 0, If[Length[beginr] == 0, If[Length[endr] == 0, Return[list], pos = Last[endr][[2,1]]; ele = Reverse[ele]; ], pos = First[beginr][[2,1]]; ], beginr = First[beginr][[2,1]]; endr = Last[endr][[2,1]]; If[((endr-beginr == 1) || ((endr < beginr) && (endr-beginr =!= -1))), pos = beginr, pos = endr; ele = Reverse[ele]]; ]; Join[Take[list, pos], ele, Drop[list,pos]] ] (* A boolean function based on code found in the source 'Graphics Gems' which returns whether the given point is within the specified triangle. *) PointInTriangleQ[point_, triangle_] := Module[{vec, result}, vec = {point-triangle[[1]],triangle[[2]]-triangle[[1]], triangle[[3]]-triangle[[1]]}; result = LinearSolve[Transpose[Rest[vec]], First[vec]]; (And @@ Thread[result >= 0]) && ((Plus @@ result) <=1) ] (* A function based on code found in the source 'Graphics Gems' which returns the coordinates of the intersection of a ray and a triangle in three dimensions. $Failed is returned if the ray and the triangle do not intersect at all. *) RayTriIntersect[ray_, tri_, bbox_] := Module[{norm, mxnorm, term, t, pt, nr, rayo=ray[[1]], raydir= -Subtract @@ ray}, norm = Cross[tri[[2]]-tri[[1]],tri[[3]]-tri[[1]]]; nr = norm . raydir; If[ N[nr] == 0.0, Return[$Failed]]; t = -((rayo-tri[[1]]) . norm )/nr; If[ t < 0 || t > 1, Return[$Failed]]; pt = rayo + raydir*t; If[!within[pt, bbox], Return[$Failed]]; mxnorm = Max[Abs /@ norm]; term = Select[MapIndexed[List,norm],Abs[#[[1]]] == mxnorm&,1][[1,2]]; If[PointInTriangleQ[Drop[pt,term], Drop[#,term]& /@ tri], pt, $Failed] ] (* A function based on code found in the source 'Graphics Gems' which returns the coordinates of the intersection of a ray and a box. $Failed is returned if the ray and the box do not intersect at all. Note, this code works on both 2D and 3D rays and boxes (cubes). *) RayBoxIntersect[outone_, outtoin_, region_] := Module[{tmp, quadrant, candidatePlane, maxT, theMax, trregion = Transpose[region]}, {quadrant, candidatePlane} = MapThread[ If[ #2 < #1[[1]], {1,#1[[1]]}, If[ #2 > #1[[2]], {0,#1[[2]]},{2,0}]]&, {trregion, outone}] // Transpose; maxT = MapThread[If[(#1 =!= 2) && (#2 =!= 0.0), (#3-#4)/#2, -1]&, {quadrant, outtoin, candidatePlane, outone}]; theMax = Max[maxT]; If[theMax < 0, Return[$Failed]]; MapThread[ If[#2 =!= theMax, tmp = #1+theMax*#3; If[(tmp < #6[[1]]) || (tmp > #6[[2]]), $Failed, tmp], #4]&, {outone, maxT, outtoin, candidatePlane, quadrant, trregion}] ] (* This function takes a ray in 2D or 3D which is known already to intersect a region, with one endpoint inside the region and one outside. If inSegment is True then the part of the ray segment inside the region is returned, otherwise, the ray segment outside the region is returned. *) splitSeg[{pt1_,pt2_}, region_, inSegment_] := Module[{outone, outtoin, isFirst, result, inCenter, candidatePlane, maxT, theMax}, If[within[pt1,region],outone = pt2; isFirst = False; outtoin = pt1-outone;, isFirst = True; outone = pt1; outtoin = pt2-outone;]; result = RayBoxIntersect[outone, outtoin, region]; If[inSegment, If[isFirst, {result,pt2}, {pt1,result}], If[isFirst, {pt1,result}, {result,pt2}] ] ] (* This function takes a ray in 2D or 3D which does not have either endpoint inside the region, but a check is made to see if it passes through the region. If in fact, the ray does not pass through the region, $Failed is returned. If inSegment is True then the part of the ray that passes though the region is returned, otherwise, a list of the two ray segments outside the region is returned.*) subSeg[{pt1_, pt2_}, region_, inSegment_] := Module[{result}, result = RayBoxIntersect[pt1, pt2-pt1, region]; If[inSegment, If[FreeQ[result,$Failed], {result, RayBoxIntersect[pt2, pt1-pt2, region]}, {}], If[FreeQ[result,$Failed], $Intersect = True; {{pt1,result}, {RayBoxIntersect[pt2, pt1-pt2, region],pt2}}, {pt1,pt2}] ] ] (* A boolean function which returns True if the list of points (2D or 3D) all lie to one side of the region specified by trregion = Transpose[region]. This is a nice quick check to see if we really need to worry about this list with regard to the region we are interested in. *) onOneSide[pts_, trregion_] := Or @@ MapThread[ (And @@ Thread[#1 < #2[[1]]] || And @@ Thread[#1 > #2[[2]]])&, {Transpose[pts],trregion}] (* A function for both 2D and 3D which returns the intersection between two rectangles (cubes). *) intersectionRect[{rmin:{_,_},rmax:{_,_}}, {{xmin_,ymin_,___},{xmax_,ymax_,___}}] := Module[{rect}, rect = {MapThread[Max,{rmin, {xmin,ymin}}], MapThread[Min,{rmax, {xmax,ymax}}]}; If[Or @@ Thread[rect[[2]] < rect[[1]]], {}, rect] ] intersectionRect[{rmin:{_,_,_},rmax:{_,_,_}}, {{xmin_,ymin_,zmin_:-Infinity},{xmax_,ymax_,zmax_:Infinity}}] := Module[{rect}, rect = {MapThread[Max,{rmin, {xmin,ymin,zmin}}], MapThread[Min,{rmax, {xmax,ymax,zmax}}]}; If[Or @@ Thread[rect[[2]] < rect[[1]]], {}, rect] ] (* A function for both 2D and 3D which returns a list of rectangles making up the region of {min,max} outside of the region {smin,smax}. Further improvements can be made with regard to looks, not speed, because you could go through the rects returned by this function and create larger rects (sometimes) out of the rects returned currently. *) removeRect[{smin:{_,_},smax:{_,_}}, {min:{_,_},max:{_,_}}] := Module[{rectlist}, rectlist = Transpose[ Outer[List, Sequence @@ Transpose[{min,smin,smax,max}]]]; rectlist = Flatten[ Table[{rectlist[[i,j]], rectlist[[i+1,j+1]]}, {i,1,3},{j,1,3}], 1]; rectlist = Select[rectlist,# =!= {smin,smax}&]; Select[rectlist,(And @@ MapThread[(#1 =!= #2)&,#])&] ] removeRect[{smin:{_,_,_},smax:{_,_,_}}, {min:{_,_,_},max:{_,_,_}}] := Module[{rectlist}, rectlist = Transpose[ Outer[List, Sequence @@ Transpose[{min,smin,smax,max}]]]; rectlist = Flatten[ Table[{rectlist[[i,j,k]], rectlist[[i+1,j+1,k+1]]}, {i,1,3},{j,1,3},{k,1,3}], 2]; rectlist = Select[rectlist,# =!= {smin,smax}&]; Select[rectlist,(And @@ MapThread[(#1 =!= #2)&,#])&] ] (* A function for integer 2D arrays which returns a list of rectangles making up the region of {min,max} outside of the region {smin,smax}. Further improvements can be made with regard to looks, not speed, because you could go through the rects returned by this function and create larger rects (sometimes) out of the rects returned currently. *) removeArrayRect[{smin:{_,_},smax:{_,_}}, {min:{_,_},max:{_,_}}] := Module[{rectlist}, rectlist = Transpose[ Outer[List, Sequence @@ Transpose[{min,smin,smax,max}]]]; rectlist = Flatten[Table[{rectlist[[i,j]], rectlist[[i+1,j+1]]}, {i,1,3},{j,1,3}],1]; rectlist = Select[rectlist,# =!= {smin,smax}&]; rectlist = Select[rectlist,(And @@ MapThread[(#1 <= #2)&,#])&]; rectlist = If[#[[2,1]] > max[[1]] || #[[1,1]] < min[[1]], {{#[[1,1]]+1,#[[1,2]]},{#[[2,1]]-1,#[[2,2]]}},#]& /@ rectlist; If[#[[2,2]] > max[[2]] || #[[1,2]] < min[[2]], {{#[[1,1]],#[[1,2]]+1},{#[[2,1]],#[[2,2]]-1}},#]& /@ rectlist ] (* These functions are used with rotating and modifying Raster and RasterArray graphics primitives by defining equivalent polygons for each cell in the Raster mesh *) makeEndPoints[origin_, size_, {y_,x_}] := Module[{begin, end}, begin = origin + ({x,y}-1)*size; end = begin + size; {begin,{begin[[1]],end[[2]]},end,{end[[1]],begin[[2]]}} ] makePolygon[origin_, size_, {y_,x_}] := Polygon[makeEndPoints[origin, size, {y,x}]] (* Generalized functions for simple transformations which standardize the code elsewhere so that you do not have to think specifically in 2D, 3D, or zValue (single value) terms. *) translate[vec:{_,_},{xdis_:0,ydis_:0,___}] := vec+{xdis,ydis} translate[vec:{_,_,_},{xdis_:0,ydis_:0,zdis_:0}] := vec+{xdis,ydis,zdis} translate[zValue_,{xdis_:0,ydis_:0,zdis_:0}] := zValue+zdis rotate[vec:{_,_}, {{a_,b_,_},{c_,d_,_},{_,_,_}}, {0,0,___}] := {{a,b},{c,d}} . vec rotate[vec:{_,_}, {{a_,b_,_},{c_,d_,_},{_,_,_}}, origin_] := translate[{{a,b},{c,d}} . translate[vec,-origin], origin] rotate[vec:{_,_}, {{a_,b_},{c_,d_}}, {0,0,___}] := {{a,b},{c,d}} . vec rotate[vec:{_,_}, {{a_,b_},{c_,d_}}, origin_] := translate[{{a,b},{c,d}} . translate[vec,-origin], origin] rotate[vec:{_,_,_}, rotmat_, {0,0,0}] := rotmat . vec rotate[vec:{_,_,_}, rotmat_, origin_] := translate[rotmat . translate[vec,-origin], origin] scale[vec:{_,_},{sx_,sy_,_}, {0,0,___}] := {sx,sy}*vec scale[vec:{_,_},{sx_,sy_,_}, origin_] := translate[{sx,sy}*translate[vec,-origin], origin] scale[vec:{_,_,_},s_, {0,0,0}] := s*vec scale[vec:{_,_,_},s_, origin_] := translate[s * translate[vec,-origin], origin] scale[zValue_,{_,_,sz_}, {0,0,0}] := sz*zValue scale[zValue_,{_,_,sz_}, origin_] := translate[ sz*translate[zValue,-origin], origin] (* definition of the exported functions *) (************************************************************************) (* BoundingRegion *) (************************************************************************) BoundingRegion[(f:(Graphics | Graphics3D))[list_,___]] := BoundingRegion[{list}] BoundingRegion[(f:(SurfaceGraphics | DensityGraphics | ContourGraphics))[array_,op___]] := Module[{rang}, rang = MeshRange /. Flatten[{op}] /. Options[f]; If[rang === Automatic,rang = {{0,0},Reverse[Dimensions[array]]}, rang = Transpose[rang]]; MapThread[Append[#1,#2]&,{rang, {Min[#],Max[#]}&[Flatten[array]]}] ] BoundingRegion[GraphicsArray[list_,___]] := With[{level = If[MatrixQ[list],2,1]}, Map[BoundingRegion,list,{level}] ] BoundingRegion[d_List] := Module[{lists,x,y,z}, lists = Select[BoundingRegion /@ d, (# =!= {})&]; If[Length[lists] < 1, Return[{}]]; lists = Transpose[lists]; x = Map[First, lists,{2}]; y = Map[#[[2]]&, lists,{2}]; z = Flatten /@ Map[If[Length[#] == 3,#[[3]],{}]&, lists,{2}]; lists = Transpose[{x,y,z}]; lists = {Min /@ lists[[1]], Max /@ lists[[2]]}; If[lists[[1,3]] == Infinity && lists[[2,3]] == -Infinity, lists = Drop[#,-1]& /@ lists]; lists ] BoundingRegion[Point[d_List]] := boundingBox[{d}] BoundingRegion[(f:(Line | Polygon))[d_List]] := boundingBox[d] BoundingRegion[Cuboid[min_List]] := {min,min+1} BoundingRegion[(f:(Rectangle | Cuboid))[min_List, max_List, ___]] := {min,max} BoundingRegion[(f:(Circle | Disk))[d_List, r:(_?numberQ | _List),___]] := {d-r,d+r} BoundingRegion[Raster[array_, range_List:{Automatic}, zrange_List:{0,1},___]] := Module[{rang}, rang = If[range == {Automatic},{{0,0}, Reverse[Dimensions[array]]}, range]; MapThread[Append[#1,#2]&,{rang, zrange}] ] BoundingRegion[RasterArray[array_, range_List:{Automatic}]] := If[range == {Automatic}, {{0,0}, Reverse[Dimensions[array]]}, range] BoundingRegion[Text[expr_, d_List, opts___]] := {d,d} BoundingRegion[expr_] := {} (************************************************************************) (* SliceGraphics *) (************************************************************************) SliceGraphics::slratio = "Warning: SliceRatios must be a list whose length equals the number of slices desired. Creating equally sized slices." SliceGraphics::slspace = "Warning: SliceSpacing must be a list whose length equals n-1 where n equals the number of slices desired. Spreading slices equally." SliceGraphics[gr_, n_Integer?Positive, opts___] := Module[{spr,sze,ax,regs,trans,pr, tgopts,rotmat,rgr=gr,arbitAxis=False, zang,yang,newax,ymat}, {spr, ax, sze} = {SliceSpacing, Axis, SliceRatios} /. {opts} /. Options[SliceGraphics]; If[Length[ax] === 2, ax = Append[ax,0]]; ax = ax/Sqrt[ax.ax]; If[ ! Or @@ Map[ax === #&,{{1,0,0},{0,1,0},{0,0,1}}], arbitAxis = True; zang = If[N[ax[[1]]] == 0 && N[ax[[2]]] == 0, 0, ArcTan[ax[[1]],ax[[2]]]]; If[Head[rgr] === Graphics || Head[rgr] === DensityGraphics || Head[rgr] === ContourGraphics, rotmat = RotationMatrix2D[zang] // N, rotmat = RotationMatrix3D[zang,0,0]; newax = rotmat.ax; yang = If[N[newax[[1]]] == 0 && N[newax[[3]]] == 0, 0,ArcTan[newax[[1]], newax[[3]]]]; ymat = RotationMatrix2D[yang]; rotmat = {{ymat[[1,1]],0, ymat[[1,2]]},{0,1,0}, {ymat[[2,1]],0, ymat[[2,2]]}}.rotmat // N ]; rgr = RotateGraphics[rgr, rotmat]]; If[ n === 1, sze = {}; spr = {0}, pr = BoundingRegion[rgr]; If[Length[pr] < 1, Return[Table[gr,{n}]]]; pr = Transpose[pr]; pr = Switch[ax, {0,1,0},pr[[2]], {0,0,1},Last[pr], _,First[pr]]; If[sze === Automatic, sze = Table[1,{n}]]; If[Length[sze] =!= n, Message[SliceGraphics::slratio]; sze = Table[1,{n}]]; If[spr === Automatic, spr = Table[-(Subtract @@ pr)/(2 n),{n-1}]]; If[numberQ[spr], spr = Table[spr,{n-1}]]; If[Length[spr] =!= n-1, Message[SliceGraphics::slspace]; spr = Table[-(Subtract @@ pr)/(2 n),{n-1}]]; sze = Abs /@ sze; spr = Abs /@ spr; sze = sze/(Plus @@ sze); sze = pr[[1]] + FoldList[Plus, First[sze], Drop[Rest[sze], -1] ] (-Subtract @@ pr); spr = FoldList[Plus,First[spr],Rest[spr]]; spr = Join[{0},spr] - Last[spr]/2]; regs = {#,{-Infinity,Infinity},{-Infinity,Infinity}}& /@ Partition[Join[{-Infinity}, sze, {Infinity}], 2,1]; trans = {spr, Table[0,{n}], Table[0,{n}]}; regs = Switch[ax, {0,1,0},Transpose[RotateRight[#,1]]& /@ regs, {0,0,1},Transpose[RotateRight[#,2]]& /@ regs, _, Transpose /@ regs ] // N; trans = Transpose[ Switch[ax, {0,1,0},RotateRight[trans,1], {0,0,1},RotateRight[trans,2], _,trans] ] // N; tgopts = FilterOptions[TakeGraphics,opts]; rgr = MapThread[TranslateGraphics[#1,#2]&, {TakeGraphics[rgr,#, tgopts]& /@ regs, trans}]; If[ arbitAxis, RotateGraphics[#,Inverse[rotmat]]& /@ rgr, rgr] ] /; Or @@ (MatchQ[Head[gr],#]& /@ {Graphics, Graphics3D, SurfaceGraphics, ContourGraphics, DensityGraphics}) SliceGraphics[GraphicsArray[list_, op___], n_Integer?Positive, opts___] := Module[{level = If[MatrixQ[list],2,1]}, GraphicsArray[Map[Show[SliceGraphics[#,n,opts], DisplayFunction->Identity]&,list,{level}],op] ] (************************************************************************) (* TakeGraphics *) (************************************************************************) TakeGraphics[expr_, {{minx_:-Infinity,miny_:-Infinity,minz_:-Infinity}, {maxx_:Infinity,maxy_:Infinity,maxz_:Infinity}}, opts___] := Module[{isInset, modify, region = {{minx,miny,minz},{maxx,maxy,maxz}}}, {isInset, modify} = {RegionTest, ModifyGraphics} /. {opts} /. Options[TakeGraphics]; If[ isInset === Inset, isInset = True, isInset = False]; If[TrueQ[modify], makeRegionPts[region]]; EG0[expr, region, isInset, TrueQ[modify]] ] EG0[(f:(Graphics | Graphics3D))[list_, op___], others__] := f[ EG0[list, others], op ] EG0[DensityGraphics[array_,op___], region_, isInset_, modify_] := Module[{dim=Reverse[Dimensions[array]], rang, dx, arr = array, cf, msh, mstyle, zmin, zmax, endpoints, grphcs}, {rang, cf, msh, mstyle} = {MeshRange, ColorFunction, Mesh, MeshStyle} /. Flatten[{op}] /. Options[DensityGraphics]; If[mstyle === Automatic, mstyle = {GrayLevel[0], Thickness[0.0015], Dashing[{}]}]; If[cf === Automatic, cf = GrayLevel]; If[rang === Automatic,rang = {{0,0},dim}, rang = Transpose[rang]]; dx = -(Apply[Subtract,Transpose[rang],{1}])/ dim; zmin = Min[Flatten[arr]]; zmax = Max[Flatten[arr]]; arr = Select[Flatten[MapIndexed[List,arr,{2}],1], within[#[[1]],region]&]; arr = {(#[[1]]-zmin)/(zmax-zmin),#[[2]]}& /@ arr; arr = {If[#[[1]] < 0,0,If[#[[1]] > 1,1,#[[1]]]],#[[2]]}& /@ arr; endpoints = makeEndPoints[rang[[1]], dx, #[[2]]]& /@ arr; grphcs = MapThread[{cf[#1[[1]]], Polygon[#2]}&, {arr, endpoints}]; If[msh, grphcs = Join[grphcs, {Join[mstyle,Flatten[Line[Append[#,First[#]]]& /@ endpoints]]}] ]; EG0[Graphics[grphcs, Evaluate[FilterOptions @@ Join[{Graphics, op},Options[DensityGraphics]]]], region, isInset, modify] ] /; ((Length[Transpose[region]] == 3 && (Or @@ (numberQ[#]& /@ Transpose[region][[3]]))) || TrueQ[modify]) EG0[gr_ContourGraphics, region_, isInset_, modify_] := EG0[Graphics[gr],region, isInset, modify] /; TrueQ[modify] EG0[gr_SurfaceGraphics, region_, isInset_, modify_] := EG0[Graphics3D[gr],region, isInset, modify] /; ((Length[Transpose[region]] == 3 && (Or @@ (numberQ[#]& /@ Transpose[region][[3]]))) || TrueQ[modify]) EG0[SurfaceGraphics[array_, shades_List?MatrixQ, op___], others__] := EG0[Graphics3D[SurfaceGraphics[array,shades,op]],others] EG0[(f:(SurfaceGraphics | DensityGraphics | ContourGraphics))[array_, op___], region_, isInset_, modify_] := Module[{dim=Dimensions[array], reg = Transpose[Take[Transpose[region],2]], rang, dx}, rang = MeshRange /. Flatten[{op}] /. Options[f]; If[rang == Automatic,rang = Transpose[{{0,0},dim}]]; dx = -(Apply[Subtract,rang,{1}])/ dim; rang = Transpose[rang]; reg = MapThread[If[Abs[#1] == Infinity,#2,#1]&,{reg,rang},2]; reg = Transpose[(Transpose[reg]-rang[[1]])/dx]; reg = {(Max[{#,1}])& /@ If[isInset,Ceiling,Floor][reg[[1]]], MapThread[Min[{#1,#2}]&, {If[isInset,Floor,Ceiling][reg[[2]]],dim}]}; If[And @@ Thread[dim >= reg[[1]]] && And @@ Thread[dim >= reg[[2]]] && And @@ Thread[reg[[1]] <= reg[[2]]], f[(Take[#, First /@ reg])& /@ Take[array, Last /@ reg], MeshRange->Transpose[reg]*dx+rang[[1]],op],{}] ] EG0[GraphicsArray[list_, op___], others__] := Module[{level = If[MatrixQ[list],2,1]}, GraphicsArray[Map[EG0[#,others]&,list,{level}],op] ] EG0[d_List, others__] := Select[Map[ EG0[#, others]& , d ], (# =!= {})&] EG0[Point[d_List], region_, __] := If[within[d,region], Point[d],{}]; EG0[Line[d_List], region_, isInset_, modify_] := Module[{vals, nreg = region}, vals = {#,within[#,region]}& /@ d; vals = Transpose /@ Partition[vals,2,1]; If[modify, If[Length[First[d]] === 2, nreg = Take[#,2]& /@ nreg]; vals = If[ Xor @@ #[[2]], {{},splitSeg[#[[1]],nreg,True]}, If[ And @@ #[[2]], #[[1]], If[ onOneSide[#[[1]], Transpose[nreg]], {}, {{},subSeg[#[[1]],nreg,True]} ] ] ]& /@ vals, vals = If[If[isInset,And,Or] @@ #[[2]],#[[1]],{}]& /@ vals ]; Line /@ simplifyVals[vals] ] EG0[Rectangle[min_List, max_List, graphics__], region_, isInset_,__] := If[ If[isInset,And,Or] @@ {within[min,region],within[max,region]}, Rectangle[min,max,graphics], {}] EG0[Cuboid[min_List], others__] := EG0[Cuboid[min,min+1], others] EG0[(f:(Rectangle | Cuboid))[min_List, max_List], region_, isInset_, modify_] := Module[{rect, nmin, nmax}, If[modify, {nmin, nmax} = Transpose[Sort /@ Transpose[{min,max}]]; rect = intersectionRect[{nmin,nmax}, region]; If[rect == {},{}, f[Sequence @@ rect]], If[ If[isInset,And,Or] @@ {within[min,region], within[max,region]}, f[min,max], {}] ] ] EG0[Polygon[d_List], region_, isInset_, modify_] := Module[{vals, rpts, rlist, nreg = region}, If[modify, If[Length[First[d]] === 2, nreg = Take[#,2]& /@ nreg]; vals = {#,within[#,nreg]}& /@ d; If[And @@ Transpose[vals][[2]], Return[Polygon[d]]]; If[onOneSide[d, Transpose[nreg]], Return[{}]]; vals = Transpose /@ Join[Partition[vals,2,1], {{Last[vals],First[vals]}}]; vals = If[ And @@ #[[2]], #[[1]], If[ Xor @@ #[[2]], splitSeg[#[[1]],nreg,True], If[ onOneSide[#[[1]], Transpose[nreg]], {}, subSeg[#[[1]],nreg,True] ] ] ]& /@ vals; rpts = regionPts[d]; vals = Flatten[ Select[ vals, # =!= {}&], 1]; If[Length[vals] > 0, If[Length[vals] > 1, vals = Fold[ If[#2 == Last[#1],#1,Append[#1,#2]]&, {First[vals]},Rest[vals]] ]; If[Length[rpts] > 0, If[Length[rpts] > 1, rlist = Select[ Fold[ sepRList, {{}}, rpts], Length[#]>0&], rlist = {rpts}]; vals = Fold[addRpts, vals, rlist]; ]; Polygon[vals], If[Length[rpts] > 0, Polygon[rpts],{}]] , If[ If[isInset,And,Or] @@ (within[#,region]& /@ d), Polygon[d], {}] ] ] EG0[(f:(Circle | Disk))[d_List, r:(_?numberQ | _List), t___], region_, isInset_,__] := If[ If[isInset,And,Or] @@ {within[d-r,region],within[d+r,region]}, f[d,r,t],{}] EG0[Raster[array_, range_List:{Automatic}, zrange_List:{0,1}, colorFunc_Rule:(ColorFunction->Automatic)], region_, isInset_, modify_] := Module[{dim=Reverse[Dimensions[array]], reg = Transpose[Take[Transpose[region],2]], rang, dx, cf, arr=array, zmin = zrange[[1]], zmax = zrange[[2]]}, cf = ColorFunction /. {colorFunc}; If[cf === Automatic, cf = GrayLevel]; rang = If[range == {Automatic},{{0,0}, dim}, range]; dx = -(Apply[Subtract,Transpose[rang],{1}])/ dim; If[modify || (Length[Transpose[region]] == 3 && (Or @@ (numberQ[#]& /@ Transpose[region][[3]]))), arr = Select[Flatten[MapIndexed[List,arr,{2}],1], within[#[[1]],region]&]; arr = {(#[[1]]-zmin)/(zmax-zmin),#[[2]]}& /@ arr; arr = {If[#[[1]] < 0,0,If[#[[1]] > 1,1,#[[1]]]],#[[2]]}& /@ arr; EG0[ {cf[#[[1]]], makePolygon[rang[[1]], dx, #[[2]]]}& /@ arr, region, isInset, modify] , reg = MapThread[If[Abs[#1] == Infinity,#2,#1]&,{reg,rang},2]; reg = Transpose[(Transpose[reg]-rang[[1]])/dx]; reg = {(Max[{#,0}]+1)& /@ If[isInset,Ceiling,Floor][reg[[1]]], MapThread[Min[{#1,#2}]&, {If[isInset,Floor,Ceiling][reg[[2]]],dim}]}; If[And @@ Thread[dim >= reg[[1]]] && And @@ Thread[dim >= reg[[2]]] && And @@ Thread[reg[[1]] <= reg[[2]]], Raster[(Take[#, First /@ reg])& /@ Take[array, Last /@ reg], Transpose[Transpose[{reg[[1]]-1,reg[[2]]}]*dx+rang[[1]]], zrange, colorFunc],{}] ] ] EG0[RasterArray[array_, range_List:{Automatic}], region_, isInset_,modify_] := Module[{dim=Reverse[Dimensions[array]], reg = Transpose[Take[Transpose[region],2]], rang, dx}, rang = If[range == {Automatic},{{0,0}, dim}, range]; dx = -(Apply[Subtract,Transpose[rang],{1}])/ dim; If[modify, EG0[ Flatten[Map[ {#[[1]], makePolygon[rang[[1]], dx, #[[2]]]}&, MapIndexed[List,array,{2}],{2}],1], region, isInset, modify] , reg = MapThread[If[Abs[#1] == Infinity,#2,#1]&,{reg,rang},2]; reg = Transpose[(Transpose[reg]-rang[[1]])/dx]; reg = {(Max[{#,0}]+1)& /@ If[isInset,Ceiling,Floor][reg[[1]]], MapThread[Min[{#1,#2}]&, {If[isInset,Floor,Ceiling][reg[[2]]],dim}]}; If[And @@ Thread[dim >= reg[[1]]] && And @@ Thread[dim >= reg[[2]]] && And @@ Thread[reg[[1]] <= reg[[2]]], RasterArray[(Take[#, First /@ reg])& /@ Take[array, Last /@ reg], Transpose[Transpose[{reg[[1]]-1,reg[[2]]}]*dx+rang[[1]]]],{}] ] ] EG0[Text[expr_, d_List, opts___], region_, __] := If[within[d,region], Text[expr, d, opts],{}] EG0[expr_,__] := expr (************************************************************************) (* DropGraphics *) (************************************************************************) DropGraphics[expr_, {{minx_:-Infinity,miny_:-Infinity,minz_:-Infinity}, {maxx_:Infinity,maxy_:Infinity,maxz_:Infinity}}, opts___] := Module[{isInset, modify, region = {{minx,miny,minz},{maxx,maxy,maxz}}}, {isInset,modify} = {RegionTest, ModifyGraphics} /. {opts} /. Options[DropGraphics]; If[ isInset === Inset, isInset = True, isInset = False]; If[TrueQ[modify], makeRegionPts[region]]; DG0[expr, region, isInset, TrueQ[modify]] ] DG0[(f:(Graphics | Graphics3D))[list_, op___], others__] := f[ DG0[list, others], op] DG0[DensityGraphics[array_,op___], region_, others__] := Module[{dim=Reverse[Dimensions[array]], rang, dx, arr = array, cf, msh, mstyle, zmin, zmax, endpoints, grphcs={}, drgrphcs={}, grlines={}, drlines={}, scaledarr}, {rang, cf, msh, mstyle} = {MeshRange, ColorFunction, Mesh, MeshStyle} /. Flatten[{op}] /. Options[DensityGraphics]; If[mstyle === Automatic, mstyle = {GrayLevel[0], Thickness[0.0015], Dashing[{}]}]; If[cf === Automatic, cf = GrayLevel]; If[rang === Automatic,rang = {{0,0},dim}, rang = Transpose[rang]]; dx = -(Apply[Subtract,Transpose[rang],{1}])/dim; zmin = Min[Flatten[arr]]; zmax = Max[Flatten[arr]]; arr = Select[Flatten[MapIndexed[List,arr,{2}],1], !(within[#[[1]],region] && (And @@ (Function[x,within[x,region]] /@ makeEndPoints[rang[[1]], dx, #[[2]]])))&]; endpoints = makeEndPoints[rang[[1]], dx, #[[2]]]& /@ arr; scaledarr = (#[[1]]-zmin)/(zmax-zmin)& /@ arr; scaledarr = If[# < 0,0,If[# > 1,1,#]]& /@ scaledarr; MapThread[ If[within[#1[[1]],region] && (Or @@ (Function[x,within[x,region]] /@ #2)), AppendTo[drgrphcs,{#3,#2}], AppendTo[grphcs,{#3,#2}]]&, {arr,endpoints,scaledarr}]; If[msh, grlines = {Join[mstyle, Flatten[Line[Append[#[[2]],First[#[[2]]]]]& /@ grphcs]]}; drlines = {Join[mstyle, Flatten[Line[Append[#[[2]],First[#[[2]]]]]& /@ drgrphcs]]}]; grphcs = {cf[#[[1]]], Polygon[#[[2]]]}& /@ grphcs; drgrphcs = {cf[#[[1]]], Polygon[#[[2]]]}& /@ drgrphcs; drgrphcs = DG0[Graphics[{drgrphcs, drlines}, Evaluate[FilterOptions @@ Join[{Graphics, op}, Options[DensityGraphics]]]], region, others]; Graphics[Join[First[drgrphcs],grphcs,grlines],Rest[List @@ drgrphcs]] ] DG0[gr_ContourGraphics, others__] := DG0[Graphics[gr], others] DG0[gr_SurfaceGraphics, others__] := DG0[Graphics3D[gr], others] DG0[GraphicsArray[list_, op___], others__] := Module[{level = If[MatrixQ[list],2,1]}, GraphicsArray[Map[DG0[#,others]&,list,{level}],op] ] DG0[d_List, others__] := Select[Map[ DG0[#, others]& , d ], (# =!= {})&] DG0[Point[d_List], region_, __] := If[!within[d,region], Point[d],{}]; DG0[Line[d_List], region_, isInset_, modify_] := Module[{vals, nreg = region}, vals = {#,within[#,region]}& /@ d; vals = Transpose /@ Partition[vals,2,1]; If[modify, If[Length[First[d]] === 2, nreg = Take[#,2]& /@ nreg]; vals = If[ Xor @@ #[[2]], {{},splitSeg[#[[1]],nreg,False]}, If[And @@ #[[2]], {}, If[ onOneSide[#[[1]], Transpose[nreg]], #[[1]], {{},subSeg[#[[1]],nreg,False]} ] ] ]& /@ vals, vals = If[!If[isInset,And,Or] @@ #[[2]],#[[1]],{}]& /@ vals ]; Line /@ simplifyVals[vals] ] DG0[Rectangle[min_List, max_List, graphics__], region_, isInset_,__] := If[ ! If[isInset,And,Or] @@ {within[min,region],within[max,region]}, Rectangle[min,max,graphics], {}] DG0[Cuboid[min_List], others__] := DG0[Cuboid[min,min+1], others] DG0[(f:(Rectangle | Cuboid))[min_List, max_List], region_, isInset_, modify_] := Module[{rect, nmin, nmax}, If[modify, {nmin, nmax} = Transpose[Sort /@ Transpose[{min,max}]]; rect = intersectionRect[{nmin,nmax}, region]; If[ rect == {nmin,nmax},{}, If[ rect == {}, f[nmin,nmax], Apply[f, removeRect[rect,{nmin,nmax}], {1}] ] ], If[ ! If[isInset,And,Or] @@ {within[min,region],within[max,region]}, f[min,max], {}] ] ] DG0[Polygon[d_List], region_, isInset_, modify_] := Module[{vals, rpts, rlist, nreg = region}, If[modify, $Intersect = False; If[Length[First[d]] === 2, nreg = Take[#,2]& /@ nreg]; vals = {#,within[#,nreg]}& /@ d; If[And @@ Transpose[vals][[2]], Return[{}]]; If[onOneSide[d, Transpose[nreg]], Return[Polygon[d]]]; vals = Transpose /@ Join[Partition[vals,2,1], {{Last[vals],First[vals]}}]; vals = If[ And @@ #[[2]], $Intersect = True; {}, If[ Xor @@ #[[2]], $Intersect = True; {{},splitSeg[#[[1]],nreg,False]}, If[ onOneSide[#[[1]], Transpose[nreg]], #[[1]], {{},subSeg[#[[1]],nreg,False]} ] ] ]& /@ vals; vals = simplifyVals[vals]; rpts = regionPts[d]; If[!TrueQ[$Intersect] && Length[rpts] > 0, Return[DG0[Polygon[#],region,False,True]& /@ basictriangulate[First[vals]] ]]; If[ Length[rpts] > 0, If[Length[rpts] > 1, rlist = Select[ Fold[ sepRList, {{}}, rpts], Length[#]>0&], rlist = {rpts}]; vals = Fold[addRpts,#,rlist]& /@ vals]; Polygon /@ vals , If[ ! If[isInset,And,Or] @@ (within[#,region]& /@ d), Polygon[d], {}] ] ] DG0[(f:(Circle | Disk))[d_List, r:(_?numberQ | _List), t___], region_, isInset_, __] := If[ ! If[isInset,And,Or] @@ {within[d-r,region],within[d+r,region]}, f[d,r,t],{}] DG0[Raster[array_, range_List:{Automatic}, zrange_List:{0,1}, colorFunc_Rule:(ColorFunction->Automatic)], region_, isInset_,modify_] := Module[{dim=Reverse[Dimensions[array]], reg = Transpose[Take[Transpose[region],2]], rang, dx, cf, arr=array, zmin = zrange[[1]], zmax = zrange[[2]], endPoints, scaledarr}, cf = ColorFunction /. {colorFunc}; If[cf === Automatic, cf = GrayLevel]; rang = If[range === {Automatic},{{0,0}, dim}, range]; dx = -(Apply[Subtract,Transpose[rang],{1}])/ dim; If[modify || (Length[Transpose[region]] == 3 && (Or @@ (numberQ[#]& /@ Transpose[region][[3]]))), arr = Select[Flatten[MapIndexed[List,arr,{2}],1], !(within[#[[1]],region] && (And @@ (Function[x,within[x,region]] /@ makeEndPoints[rang[[1]], dx, #[[2]]])))&]; endPoints = makeEndPoints[rang[[1]], dx, #[[2]]]& /@ arr; scaledarr = (#[[1]]-zmin)/(zmax-zmin)& /@ arr; scaledarr = If[# < 0,0,If[# > 1,1,#]]& /@ scaledarr; MapThread[ If[within[#1[[1]],region] && (Or @@ (Function[x,within[x,region]] /@ #2)), DG0[ {cf[#3], Polygon[#2]}, region, isInset, modify], {cf[#3], Polygon[#2]}]&, {arr,endPoints,scaledarr}] , reg = MapThread[If[Abs[#1] == Infinity,#2,#1]&,{reg,rang},2]; reg = Transpose[(Transpose[reg]-rang[[1]])/dx]; reg = {(Max[{#,0}]+1)& /@ If[isInset,Ceiling,Floor][reg[[1]]], MapThread[Min[{#1,#2}]&, {If[isInset,Floor,Ceiling][reg[[2]]],dim}]}; reg = removeArrayRect[{reg[[1]]-1,reg[[2]]+1},{{1,1},dim}]; Function[x, If[And @@ Thread[dim >= x[[1]]] && And @@ Thread[dim >= x[[2]]] && And @@ Thread[x[[1]] <= x[[2]]], Raster[(Take[#, First /@ x])& /@ Take[array, Last /@ x], Transpose[Transpose[{x[[1]]-1,x[[2]]}]*dx+rang[[1]]], zrange, colorFunc],{}]] /@ reg ] ] DG0[RasterArray[array_, range_List:{Automatic}], region_, isInset_,modify_] := Module[{dim=Reverse[Dimensions[array]], reg = Transpose[Take[Transpose[region],2]], rang, dx}, rang = If[range == {Automatic},{{0,0}, dim}, range]; dx = -(Apply[Subtract,Transpose[rang],{1}])/ dim; If[modify, DG0[ Flatten[Map[ {#[[1]], makePolygon[rang[[1]], dx, #[[2]]]}&, MapIndexed[List,array,{2}],{2}],1], region, isInset, modify] , reg = MapThread[If[Abs[#1] == Infinity,#2,#1]&,{reg,rang},2]; reg = Transpose[(Transpose[reg]-rang[[1]])/dx]; reg = {(Max[{#,0}]+1)& /@ If[isInset,Ceiling,Floor][reg[[1]]], MapThread[Min[{#1,#2}]&, {If[isInset,Floor,Ceiling][reg[[2]]],dim}]}; reg = removeArrayRect[{reg[[1]]-1,reg[[2]]+1},{{1,1},dim}]; Function[x, If[And @@ Thread[dim >= x[[1]]] && And @@ Thread[dim >= x[[2]]] && And @@ Thread[x[[1]] <= x[[2]]], RasterArray[(Take[#, First /@ x])& /@ Take[array, Last /@ x], Transpose[Transpose[{x[[1]]-1,x[[2]]}]*dx+rang[[1]]]],{}]] /@ reg ] ] DG0[Text[expr_, d_List, opts___], region_, __] := If[!within[d,region], Text[expr, d, opts],{}] DG0[expr_,__] := expr (************************************************************************) (* TranslateGraphics *) (************************************************************************) TranslateGraphics[expr_, dist_] := TG0[expr, dist] TG0[(f:(Graphics | Graphics3D))[list_, opts___], dist_] := f[ TG0[list, dist], opts ] TG0[SurfaceGraphics[array_, shades_List?MatrixQ, opts___], dist_] := Module[{mRange}, mRange = MeshRange /. Flatten[{opts}] /. Options[SurfaceGraphics]; If[mRange == Automatic, mRange = Transpose[{{1,1},Dimensions[array]}]]; mRange = Transpose[translate[#,dist]& /@ Transpose[mRange]]; SurfaceGraphics[Map[translate[#,dist]&,array,{2}], shades, MeshRange->mRange,opts] ] TG0[(f:(SurfaceGraphics | DensityGraphics | ContourGraphics))[array_, opts___], dist_] := Module[{mRange}, mRange = MeshRange /. Flatten[{opts}] /. Options[f]; If[mRange == Automatic, mRange = Transpose[{{1,1},Dimensions[array]}]]; mRange = Transpose[translate[#,dist]& /@ Transpose[mRange]]; f[Map[translate[#,dist]&,array,{2}], MeshRange->mRange,opts] ] TG0[GraphicsArray[list_, op___], dist_] := Module[{level = If[MatrixQ[list],2,1]}, GraphicsArray[Map[TG0[#,dist]&,list,{level}],op] ] TG0[d_List, dist_] := Map[ TG0[#, dist]& , d ] TG0[Point[d_List], dist_] := Point[translate[d,dist]]; TG0[Line[d_List], dist_] := Line[translate[#,dist]& /@ d] TG0[Rectangle[min_List, max_List, graphics___], dist_] := Rectangle[translate[min,dist],translate[max,dist],graphics] TG0[Cuboid[min_List], dist_] := Cuboid[translate[min,dist]] TG0[Cuboid[min_List, max_List], dist_] := Cuboid[translate[min,dist], translate[max,dist]] TG0[Polygon[d_List], dist_] := Polygon[translate[#,dist]& /@ d] TG0[(f:(Circle | Disk))[d_List, r:(_?numberQ | _List), t___], dist_] := f[translate[d,dist],r,t] TG0[Raster[array_, range_List:{Automatic}, zrange_List:{0,1}, colorFunc_Rule:(ColorFunction->Automatic)], dist_] := Module[{dim=Reverse[Dimensions[array]], rang}, rang = If[range == {Automatic},{{0,0}, dim},range]; Raster[array, translate[#,dist]& /@ rang, zrange, colorFunc] ] TG0[RasterArray[array_, range_List:{Automatic}], dist_] := Module[{dim=Reverse[Dimensions[array]], rang}, rang = If[range == {Automatic},{{0,0}, dim},range]; RasterArray[array, translate[#,dist]& /@ rang] ] TG0[Text[expr_, d_List, opts___], dist_] := Text[expr, translate[d, dist], opts] TG0[expr_,_] := expr (************************************************************************) (* RotateGraphics *) (************************************************************************) RotateGraphics[expr_, rotmat_List, origin_List:{0,0,0}, op___Rule] := Module[{txtRot}, txtRot = TextRotated /. {op} /. Options[RotateGraphics]; RG0[expr, rotmat, origin, TrueQ[txtRot]] ] /; MatrixQ[rotmat] RotateGraphics[expr_, {phi_:0, theta_:0, psi_:0}, others___] := RotateGraphics[expr, RotationMatrix3D[N[phi],N[theta],N[psi]], others] RotateGraphics[expr_, angle_?numberQ, others___] := RotateGraphics[expr, {angle,0,0}, others] RG0[(f:(Graphics | Graphics3D))[list_, opts___], others__] := f[ RG0[list, others], opts ] RG0[gr:(_DensityGraphics | _ContourGraphics), others__] := RG0[Graphics[gr], others] RG0[gr_SurfaceGraphics, others__] := RG0[Graphics3D[gr], others] RG0[GraphicsArray[list_, op___], others__] := Module[{level = If[MatrixQ[list],2,1]}, GraphicsArray[Map[RG0[#,others]&,list,{level}],op] ] RG0[d_List, others__] := Map[ RG0[#, others]& , d ] RG0[Point[d_List], rotmat_, cntr_,_] := Point[rotate[d,rotmat,cntr]]; RG0[Line[d_List], rotmat_, cntr_,_] := Line[rotate[#,rotmat,cntr]& /@ d] RG0[Rectangle[{xmin_,ymin_}, {xmax_,ymax_}], others__] := RG0[ Polygon[{{xmin,ymin}, {xmax,ymin}, {xmax,ymax}, {xmin,ymax}}], others] RG0[Rectangle[{xmin_,ymin_}, {xmax_,ymax_}, graphics_], others__] := Rectangle[{xmin,ymin},{xmax,ymax}, RG0[graphics, others]] RG0[Cuboid[min_List], others__] := RG0[Cuboid[min,min+1], others] RG0[Cuboid[{x_,y_,z_}, {xx_,yx_,zx_}], others__] := RG0[{Polygon[{{x,y,z},{xx,y,z},{xx,y,zx},{x,y,zx}}], Polygon[{{x,y,z},{x,yx,z},{x,yx,zx},{x,y,zx}}], Polygon[{{x,yx,z},{xx,yx,z},{xx,yx,zx},{x,yx,zx}}], Polygon[{{xx,y,z},{xx,yx,z},{xx,yx,zx},{xx,y,zx}}], Polygon[{{x,y,zx},{xx,y,zx},{xx,yx,zx},{x,yx,zx}}], Polygon[{{x,y,z},{xx,y,z},{xx,yx,z},{x,yx,z}}]}, others] RG0[Polygon[d_List], rotmat_, cntr_,_] := Polygon[rotate[#,rotmat,cntr]& /@ d] RG0[(f:(Circle | Disk))[d_List, r:(_?numberQ | _List)], rotmat_, cntr_,_] := f[rotate[d,rotmat,cntr],r] RG0[(f:(Circle | Disk))[d_List, r:(_?numberQ | _List), {ts_,te_} ], rotmat_, cntr_,_] := Module[{angle = ArcTan[rotmat[[1,1]],rotmat[[1,2]]]}, f[rotate[d,rotmat,cntr],r,{ts,te}-angle] ] RG0[Raster[array_, range_List:{Automatic}, zrange_List:{0,1}, colorFunc_Rule:(ColorFunction->Automatic)], others__] := Module[{dim=Reverse[Dimensions[array]], rang, dx, cf, arr = array, zmin = zrange[[1]], zmax = zrange[[2]]}, cf = ColorFunction /. {colorFunc}; If[cf === Automatic, cf = GrayLevel]; rang = If[range == {Automatic},{{0,0}, dim}, range]; dx = -(Apply[Subtract,Transpose[rang],{1}])/ dim; arr = Map[(#-zmin)/(zmax-zmin)&,arr,{2}]; arr = Map[If[# < 0,0,If[# > 1,1,#]]&,arr,{2}]; RG0[ Flatten[Map[ {cf[#[[1]]], makePolygon[rang[[1]], dx, #[[2]]]}&, MapIndexed[List,arr,{2}],{2}],1], others] ] RG0[RasterArray[array_, range_List:{Automatic}], others__] := Module[{dim=Reverse[Dimensions[array]], rang, dx}, rang = If[range == {Automatic},{{0,0}, dim}, range]; dx = -(Apply[Subtract,Transpose[rang],{1}])/ dim; RG0[ Flatten[Map[ {#[[1]], makePolygon[rang[[1]], dx, #[[2]]]}&, MapIndexed[List,array,{2}],{2}],1], others] ] RG0[Text[expr_, d:{_,_}, offset_:{0,0}, dir_:{1,0}, opts___], rotmat_, cntr_, txtRot_] := Module[{ndir = dir}, If[txtRot, ndir = rotate[ndir, rotmat, {0,0}]]; Text[expr, rotate[d, rotmat, cntr], offset, ndir, opts] ] RG0[Text[expr_, d:{_,_,_}, opts___], rotmat_, cntr_,_] := Text[expr, rotate[d, rotmat, cntr], opts] RG0[expr_,__] := expr (************************************************************************) (* ScaleGraphics *) (************************************************************************) ScaleGraphics[expr_, scale_?numberQ, others___] := ScaleGraphics[expr, {scale, scale, scale}, others] ScaleGraphics[expr_, {sx_:1,sy_:1,sz_:1}, origin_:{0,0,0}] := SG0[expr, {sx,sy,sz}, origin] SG0[(f:(Graphics | Graphics3D))[list_, opts___], others__] := f[ SG0[list, others], opts ] SG0[SurfaceGraphics[array_, shades_List?MatrixQ, opts___], s_, or_] := Module[{mRange}, mRange = MeshRange /. Flatten[{opts}] /. Options[SurfaceGraphics]; If[mRange == Automatic, mRange = Transpose[{{1,1},Dimensions[array]}]]; mRange = Transpose[scale[#,s,or]& /@ Transpose[mRange]]; SurfaceGraphics[Map[scale[#,s,or]&,array,{2}], shades, MeshRange->mRange,opts] ] SG0[(f:(SurfaceGraphics | DensityGraphics | ContourGraphics))[array_, opts___], s_, or_] := Module[{mRange}, mRange = MeshRange /. Flatten[{opts}] /. Options[f]; If[mRange == Automatic, mRange = Transpose[{{1,1},Dimensions[array]}]]; mRange = Transpose[scale[#,s,or]& /@ Transpose[mRange]]; f[Map[scale[#,s,or]&,array,{2}], MeshRange->mRange,opts] ] SG0[GraphicsArray[list_, op___], others__] := Module[{level = If[MatrixQ[list],2,1]}, GraphicsArray[Map[SG0[#,others]&,list,{level}],op] ] SG0[d_List, others__] := Map[ SG0[#, others]& , d ] SG0[Point[d_List], s_, or_] := Point[scale[d,s,or]]; SG0[Line[d_List], s_, or_] := Line[scale[#,s,or]& /@ d] SG0[Rectangle[min_List, max_List, graphics___], s_, or_] := Rectangle[scale[min,s,or],scale[max,s,or],graphics] SG0[Cuboid[min_List], others__] := SG0[Cuboid[min,min+1],others] SG0[Cuboid[min_List, max_List], s_, or_] := Cuboid[scale[min,s,or], scale[max,s,or]] SG0[Polygon[d_List], s_, or_] := Polygon[scale[#,s,or]& /@ d] SG0[(f:(Circle | Disk))[d_List, r:(_?numberQ | _List), t___], s_, or_] := With[{dscale = scale[d,s,or]}, f[dscale,Abs[scale[d+r,s,or]-dscale],t] ] SG0[Raster[array_, range_List:{Automatic}, zrange_List:{0,1}, colorFunc_Rule:(ColorFunction->Automatic)], s_, or_] := Module[{dim=Reverse[Dimensions[array]], rang}, rang= If[range == {Automatic},{{0,0}, dim},range]; Raster[array, scale[#,s,or]& /@ rang, zrange, colorFunc] ] SG0[RasterArray[array_, range_List:{Automatic}], s_, or_] := Module[{dim=Reverse[Dimensions[array]], rang}, rang= If[range == {Automatic},{{0,0}, dim},range]; RasterArray[array, scale[#,s,or]& /@ rang] ] SG0[Text[expr_, d_List, opts___], s_, or_] := Text[expr, scale[d, s,or], opts] SG0[expr_,__] := expr (************************************************************************) (* TransformGraphics *) (************************************************************************) TransformGraphics[expr_, f_] := TRG0[expr, f] TRG0[(gr:(Graphics | Graphics3D))[list_, opts___], f_] := gr[ TRG0[list, f], opts] TRG0[gr_SurfaceGraphics, f_] := TRG0[Graphics3D[gr],f] TRG0[gr:(_DensityGraphics | _ContourGraphics), f_] := TRG0[Graphics[gr], f] TRG0[GraphicsArray[list_, op___], f_] := Module[{level = If[MatrixQ[list],2,1]}, GraphicsArray[Map[TRG0[#,f]&,list,{level}],op] ] TRG0[d_List, f_] := Map[ TRG0[#, f]& , d ] TRG0[Point[d_List], f_] := Point[f[d]] TRG0[Line[d_List], f_] := Line[f /@ d] TRG0[Rectangle[{xmin_, ymin_}, {xmax_, ymax_}], f_] := TRG0[Polygon[{{xmin,ymin}, {xmin,ymax}, {xmax, ymax}, {xmax, ymin}}], f] TRG0[Rectangle[{xmin_,ymin_}, {xmax_,ymax_}, graphics_], f_] := Rectangle[{xmin,ymin},{xmax,ymax}, TransformGraphics[graphics,f]] TRG0[Cuboid[min_List], f_] := TRG0[Cuboid[min,min+1],f] TRG0[Cuboid[{x_,y_,z_}, {xx_,yx_,zx_}], f_] := TRG0[{Polygon[{{x,y,z},{xx,y,z},{xx,y,zx},{x,y,zx}}], Polygon[{{x,y,z},{x,yx,z},{x,yx,zx},{x,y,zx}}], Polygon[{{x,yx,z},{xx,yx,z},{xx,yx,zx},{x,yx,zx}}], Polygon[{{xx,y,z},{xx,yx,z},{xx,yx,zx},{xx,y,zx}}], Polygon[{{x,y,zx},{xx,y,zx},{xx,yx,zx},{x,yx,zx}}], Polygon[{{x,y,z},{xx,y,z},{xx,yx,z},{x,yx,z}}]}, f] TRG0[Polygon[d_List], f_] := Polygon[f /@ d] TRG0[(gr:(Circle | Disk))[d_List, r_?numberQ, t___], f_] := gr[f[d], Abs[f[{r,r}]], t] TRG0[(gr:(Circle | Disk))[d_List, r_List, t___], f_] := gr[f[d], Abs[f[r]], t] TRG0[Raster[array_, range_List:{Automatic}, zrange_List:{0,1}, colorFunc_Rule:(ColorFunction->Automatic)], f_] := Module[{dim=Reverse[Dimensions[array]], rang, dx, cf, arr = array, zmin = zrange[[1]], zmax = zrange[[2]]}, cf = ColorFunction /. {colorFunc}; If[cf === Automatic, cf = GrayLevel]; rang = If[range == {Automatic},{{0,0}, dim}, range]; dx = -(Apply[Subtract,Transpose[rang],{1}])/ dim; arr = Map[(#-zmin)/(zmax-zmin)&,arr,{2}]; arr = Map[If[# < 0,0,If[# > 1,1,#]]&,arr,{2}]; TRG0[ Flatten[Map[ {cf[#[[1]]], makePolygon[rang[[1]], dx, #[[2]]]}&, MapIndexed[List,arr,{2}],{2}],1], f] ] TRG0[RasterArray[array_, range_List:{Automatic}], f_] := Module[{dim=Reverse[Dimensions[array]], rang, dx}, rang = If[range == {Automatic},{{0,0}, dim}, range]; dx = -(Apply[Subtract,Transpose[rang],{1}])/ dim; TRG0[ Flatten[Map[ {#[[1]], makePolygon[rang[[1]], dx, #[[2]]]}&, MapIndexed[List,array,{2}],{2}],1], f] ] TRG0[Text[expr_, d_List, opts___], f_] := Text[expr, f[d], opts] TRG0[expr_, f_] := expr (************************************************************************) (* SkewGraphics *) (************************************************************************) SkewGraphics[expr_, m_?MatrixQ] := TransformGraphics[expr, (m . #)&] (*****************************************************************************) End[] (* end `Private` Context *) (*****************************************************************************) (*****************************************************************************) EndPackage[] (* end package Context *) (*****************************************************************************)