home *** CD-ROM | disk | FTP | other *** search
/ Liren Large Software Subsidy 9 / 09.iso / e / e031 / 3.ddi / MATHZIP2 / STARTUP / GRAPHICS.M < prev    next >
Encoding:
Text File  |  1991-09-23  |  6.2 KB  |  179 lines
  1.  
  2. (* Author: Kevin McIsaac; modified by Igor Rivin, Tom Wickham-Jones and
  3.             John M. Novak *)
  4. Begin["System`"]
  5.  
  6. Unprotect[{ContourGraphics, 
  7.            SurfaceGraphics, 
  8.            DensityGraphics,
  9.        Graphics,
  10.        Graphics3D,
  11.        FullOptions,
  12.        FullGraphics,
  13.        Options
  14.        }]
  15.  
  16.  
  17. Begin["Graphics`Private`"]
  18.  
  19. FilterOptions[command_Symbol, opts___] := 
  20.     Block[{keywords = First /@ Options[command]},
  21.         Sequence @@ Select[Flatten[{opts}],
  22.                         MemberQ[keywords, First[#]]&]
  23.     ]
  24.  
  25. FullOptions[x_List,y_] :=
  26.     Map[FullOptions[#,y]&,x]
  27.  
  28. FullOptions[x_,y_List] :=
  29.     Map[FullOptions[x,#]&,y]
  30.  
  31. FullOptions[x_, y_]:=
  32.         Module[{ names},
  33.                 names = Map[ First, Options[ Head[x]]] ;
  34.                 If[ MemberQ[ names, y], (y /. FullOptions[x]),
  35.                                         Message[FullOptions::optx, y, x];
  36.                                         y ]
  37.         ] /; GTest[ Head[x]]
  38.  
  39. FullOptions[ x_] :=
  40.         Module[{plrng, opts, names, vals, asp },
  41.                 plrng = PlotRange[x] ;
  42.                 names = Map[ First, Options[ Head[x]]] ;
  43.         opts = Flatten[ If[ Length[x] == 0, {},
  44.                       Drop[ List @@ x, 1]]] ;
  45.                 opts = Select[  opts, (Head[#] == RuleDelayed ||
  46.                                        Head[#] == Rule)& ] ;
  47.                 opts = Join[ opts, Options[ Head[x]]] ;
  48.                 opts = CheckGopt[ Head[x], opts, plrng] ;
  49.                 opts = Prepend[ opts, PlotRange -> plrng] ;
  50.                 opts = Join[ GetAx[x], opts] ;
  51.                 vals = names /. opts ;
  52.                 opts = Transpose[ {names, vals}] ;
  53.                 Map[ Apply[Rule, #]&, opts]//N
  54.         ]  /; GTest[ Head[x]] && Length[x] =!= 0
  55.  
  56. GTest[ x_] := MemberQ[ {Graphics, Graphics3D, GraphicsArray,
  57.                         SurfaceGraphics, DensityGraphics,
  58.                         ContourGraphics}, x]
  59.  
  60. CheckGopt[ x_, opts_, plrng_] :=
  61.         Module[{asp, xmin, xmax,
  62.                      ymin, ymax},
  63.                 asp = AspectRatio /. opts ;
  64.                 If[ asp === Automatic,
  65.                         {{xmin, xmax}, {ymin, ymax}} = Take[ plrng, {1,2}];
  66.                         If[ xmin != xmax, asp = ((ymax-ymin)/(xmax-xmin)),
  67.                                           asp = 1., asp = 1.] ;
  68.                         Prepend[ opts, AspectRatio -> asp] ,
  69.                         opts ]
  70.         ] /; MemberQ[ { Graphics, GraphicsArray,
  71.                         ContourGraphics, DensityGraphics}, x]
  72.  
  73. CheckGopt[ x_, opt_, plrng_] :=
  74.         Module[{box, xmin, xmax,
  75.                      ymin, ymax,
  76.                      zmin, zmax, opts = opt, vc},
  77.                 vc = ViewCenter /. opts ;
  78.                 If[ vc == Automatic, opts =
  79.                           Prepend[ opts, ViewCenter -> {.5,.5,.5}]] ;
  80.                 box = BoxRatios /. opts ;
  81.                 If[ box === Automatic,
  82.                         {{xmin, xmax}, {ymin, ymax}, {zmin, zmax}} =  plrng;
  83.                         If[ zmin != zmax, box = {((xmax-xmin)/(zmax-zmin)),
  84.                                                  ((ymax-ymin)/(zmax-zmin)),
  85.                                                    1.},
  86.                                         box = {1.,1.,1.},
  87.                                         box = {1.,1.,1.}] ;
  88.                         Prepend[ opts, BoxRatios -> box],
  89.                         opts]
  90.         ] /; MemberQ[ { SurfaceGraphics, Graphics3D}, x]
  91.  
  92.  
  93. GetAx[x_Graphics] :=
  94.         Module[{ res, xax, yax,
  95.                       xaxs, yaxs,
  96.                       xorg, yorg,
  97.                       xlab, ylab,
  98.                       xstyl, ystyl,
  99.                       x1ax, y1ax, x2ax, y2ax,
  100.                       x1xs, y1xs, x2xs, y2xs,
  101.                       x1lab, y1lab, x2lab, y2lab,
  102.                       x1styl, y1styl, x2styl, y2styl },
  103.  
  104.                 res = FullAxes[x] ;
  105.         If[ Head[ res] === FullAxes, Return[{}]] ;
  106.                 {xax, yax} = Map[ OptFlat[#,3]&, Axes /. res] ;
  107.                 {xaxs, xorg, xlab, xstyl} = GetAx1[ xax] ;
  108.                 {yaxs, yorg, ylab, ystyl} = GetAx1[ yax] ;
  109.                 {x1ax, y1ax, x2ax, y2ax} = Map[ OptFlat[#,2]&, Frame /. res]
  110. ;
  111.                 {x1xs, x1lab, x1styl} = GetAx2[ x1ax] ;
  112.                 {y1xs, y1lab, y1styl} = GetAx2[ y1ax] ;
  113.                 {x2xs, x2lab, x2styl} = GetAx2[ x2ax] ;
  114.                 {y2xs, y2lab, y2styl} = GetAx2[ y2ax] ;
  115.  
  116.                 Join[ { Axes -> {xaxs, yaxs},
  117.                         AxesOrigin -> {xorg, yorg},
  118.                         AxesLabel -> {xlab, ylab},
  119.                         AxesStyle -> {xstyl, ystyl},
  120.                         Frame -> {x1xs, y1xs, x2xs, y2xs},
  121.                         FrameLabel -> {x1lab, y1lab, x2lab, y2lab},
  122.                         FrameStyle -> {x1styl, y1styl, x2styl, y2styl}},res]
  123.         ]
  124.  
  125. GetAx[x_] := {}
  126.  
  127. GetAx1[ ax_] :=
  128.         {True, ax[[1]], ax[[2]], ax[[3]]} /; Length[ax] == 3
  129. GetAx1[ ax_] :=
  130.         {False, None, None, None}
  131. GetAx2[ ax_] :=
  132.         {True, ax[[1]], ax[[2]]} /; Length[ax] == 2
  133. GetAx2[ ax_] :=
  134.         {False, None, None}
  135.  
  136.  
  137. OptFlat[ x_, n_] := Flatten[x,1] /; Length[x] == 1 && Length[x[[1]]] == n
  138. OptFlat[ x_, n_] := x
  139.  
  140. SurfaceGraphics /: 
  141. ContourGraphics[SurfaceGraphics[data_,opt___]] :=
  142.     ContourGraphics[data, Axes -> False, FilterOptions[ContourGraphics,opt]]
  143.  
  144. SurfaceGraphics /: 
  145. DensityGraphics[SurfaceGraphics[data_,opt___]] :=
  146.     DensityGraphics[data, Axes -> False,FilterOptions[ContourGraphics,opt]]
  147.  
  148. ContourGraphics /: 
  149. SurfaceGraphics[ContourGraphics[data_,opt___]] :=
  150.     SurfaceGraphics[data, FilterOptions[SurfaceGraphics,opt]]
  151.  
  152. ContourGraphics /: 
  153. DensityGraphics[ContourGraphics[data_,opt___]] :=
  154.     DensityGraphics[data, FilterOptions[DensityGraphics,opt]]
  155.  
  156. DensityGraphics /: 
  157. SurfaceGraphics[DensityGraphics[data_,opt___]] :=
  158.     SurfaceGraphics[data, FilterOptions[SurfaceGraphics,opt]]
  159.  
  160. DensityGraphics /: 
  161. ContourGraphics[DensityGraphics[data_,opt___]] :=
  162.     ContourGraphics[data, FilterOptions[ContourGraphics,opt]]
  163.  
  164. End[]
  165.  
  166. SetAttributes[ {ContourGraphics, 
  167.                 SurfaceGraphics, 
  168.                 DensityGraphics,
  169.             Graphics,
  170.             Graphics3D,
  171.             Options,
  172.          FullOptions,
  173.             FullGraphics},
  174.     {Protected,ReadProtected}]
  175.  
  176.  
  177. End[];
  178.  
  179.