
(* :Title: Filled Plot *)

(* :Context: Graphics`FilledPlot` *)

(* :Author: John M. Novak *)

(* :Summary: Plots with fills between curves of functions. *)

(* :Package Version: 1.0 *)

(* :Mathematica Version: 2.0 *)

(* :History:
	V1.0 by John M. Novak, May 1991
*)

(* :Keywords:
	graphics, Plot
*)

(* :Limitations: uses rectangles to place the axes in front
	of the filled area;  this should work in all cases, but
	is not guaranteed.
*)

BeginPackage["Graphics`FilledPlot`",
	"Utilities`FilterOptions`"]

FilledPlot::usage =
	"FilledPlot[function,{var,varmin,varmax}] generates a plot
	with the area between the curve and the var axis filled.
	FilledPlot[{f1,f2,...},range] generates a plot with the
	areas between curve f1 and f2, f2 and f3, etc. filled.
	The shade of the fill and other specifications can be
	given by the Fills option."

Fills::usage =
	"An option to FilledPlot.  There are two forms for this
	option;  a list of color primitives (i.e., Hue[0], etc.),
	or a list of pairs, with the first element being another
	pair that specifies two curves, and the other being a color
	primitive (i.e., {{2,3},Hue[.3]}, etc.).  In this second form,
	each curve is specified by an integer, indicating the
	position of the curve in the list of curves given to
	FilledPlot.  Also, the symbol Axis (meaning the x-axis) 
	can be specified.  If just the list of colors is given,
	this is equivalent to {{{1,2},color1},{{2,3},color2},etc.}.
	If there are more colors than curves, extra colors are
	ignored. If there are as many colors as curves, the last
	color is the fill between the final curve and the Axis.
	If there are fewer colors, then only the fills up through
	the given colors will be done."

Curves::usage =
	"An option to FilledPlot.  There are three possible values
	for this;  None, Front, or Back.  None means not to display
	the actual lines used for the curves; Front means to draw all
	the curves in front of the fills.  Back means to draw the
	curves used in a fill in the same layer as that fill; thus,
	some curves may be covered by later fills."

Front::usage = Back::usage =
	"A value for the option Curves."

Axis::usage =
	"Used in the option Fills to specify that one of the
	curves to be used in a fill is the x-axis."

Begin["`Private`"]

(* Curves option takes None, Front, or Back. *)

Options[FilledPlot] = Join[{
		Fills->Automatic,
		Curves->Back},
	Options[Plot]];

FilledPlot::badfill =
	"The Fills option has been given an incorrect form: `1`.";

FilledPlot::badcurv =
	"The Curves option has been given bad value `1`; using
	'Back' in its place.";

FilledPlot[funcs_List,{x_Symbol,xmin_,xmax_},opts___] :=
	Module[{pl,lines,fills,gopts,disp,rng,asp,curve,
			ln = Length[funcs],n,gr,part},
		{fills,curve,disp} = {Fills,Curves,DisplayFunction}/.
			{opts}/.Options[FilledPlot];
		pl = Plot[funcs,{x,xmin,xmax},
			DisplayFunction->Identity,
			Evaluate[FilterOptions[Plot,opts]]];
		lines = Map[Last,pl[[1]]];
		gopts = Sequence @@ Drop[pl,1];
		(* check form of curve *)
		If[!MatchQ[curve,(Front | Back | None)],
			Message[FilledPlot::badcurv,curve];
			curve = Back];
		(* check form of fills *)
		If[MatchQ[fills,_Hue | _GrayLevel | _RGBColor | _CMYKColor],
			fills = {fills}];
		If[!MatchQ[fills,({{{(_Integer | Axis),(_Integer | Axis)},
				(_Hue | _GrayLevel | _RGBColor | _CMYKColor)}..} |
				{(_Hue | _GrayLevel | _RGBColor | _CMYKColor)..} |
				Automatic)],
			Message[FilledPlot::badfill,fills]; fills = Automatic];
		If[MatchQ[fills,{(_Hue | _GrayLevel | _RGBColor | _CMYKColor)..}],
			If[Length[fills] > ln,
				fills = Take[fills,ln]];
			part = Partition[Range[1,ln],2,1];
			If[Length[fills] === ln,
				AppendTo[part,{1,Axis}]];
			fills = Transpose[{part,fills}]
		];
		If[fills === Automatic,
			If[ln === 1,
				fills = {{{1,Axis}, GrayLevel[.5]}},
				fills = Transpose[{
					Partition[Range[1,ln],2,1],
					Table[Hue[n/ln],{n,1,ln-1}]}]
			]
		];
		polys = Map[dopoly[#,lines,{xmin,xmax}]&,fills];
		gr = Switch[curve,
			Back,MapThread[{#1,
				Map[If[# =!= Axis && # =!= 0,
					pl[[1,#]],{}]&,#2[[1]]]}&,{polys,fills}],
			None,polys,
			Front,{polys,pl[[1]]}];
		gr = Graphics[gr,DisplayFunction->disp,
			Prolog->{},
			Epilog->{},
			gopts];
		{rng,asp} = FullOptions[gr,{PlotRange,AspectRatio}];
		Show[Graphics[{Rectangle[{0,0},{1,1},gr],
			Rectangle[{0,0},{1,1},
				Graphics[{PointSize[0]},
					DisplayFunction->disp,
					PlotRange->rng,
					Epilog->{},
					Prolog->{},
					gopts]]}],
			Axes->False,Frame->False,PlotLabel->None,
			AspectRatio->asp,
			DisplayFunction->disp,gopts]
	]

FilledPlot[func_,rng_List,opts___] :=
	FilledPlot[{func},rng,opts]

(* Auxiliary Functions *)

dopoly[{{first_,second_},style_},lines_,rng_] :=
	Flatten[{style,
		Outer[linestopolygon,getline[first,lines,rng],
		getline[second,lines,rng]]}]

getline[0,lines_,rng_] := getline[Axis,lines,rng]

getline[Axis,lines_,{min_,max_}] := {Line[N[{{min,0},{max,0}}]]}

getline[ln_,lines_,rng_] := lines[[ln]]/;
	ln <= Length[lines] && ln >= 1

getline[_,_,{min_,max_}] := {Line[N[{{min,0},{max,0}}]]}

(* delete to intersecting point, leading; then, delete
	to intersecting point, trailing; then, create polygon
	(no checking needed.) *)

linestopolygon[Line[line1_List],Line[line2_List]] :=
	{}/;First[Last[line1]] <= First[First[line2]] ||
		First[Last[line2]] <= First[First[line1]]

linestopolygon[Line[line1_List],Line[line2_List]] :=
	With[{f1 = First[First[line1]],f2 = First[First[line2]]},
		If[f1 > f2,
			linestopolygon[Line[line1],chopline[line2,f1,True]],
			linestopolygon[chopline[line1,f2,True],Line[line2]]]
	]/;First[First[line1]] != First[First[line2]]

linestopolygon[Line[line1_List],Line[line2_List]] :=
	With[{f1 = First[Last[line1]],f2 = First[Last[line2]]},
		If[f1 < f2,
			linestopolygon[Line[line1],chopline[line2,f1,False]],
			linestopolygon[chopline[line1,f2,False],Line[line2]]]
	]/; First[Last[line1]] != First[Last[line2]]

linestopolygon[Line[line1_List],Line[line2_List]] :=
	Polygon[Join[line1,Reverse[line2]]]

chopline[line_,pt_,front_:True] :=
	Module[{pl = Partition[line,2,1],x1,y1,x2,y2,pos},
		pos = Position[pl,
			x_?(#[[1,1]] < pt && #[[2,1]] >= pt &),
				{1},Heads->False][[1,1]];
		{{x1,y1},{x2,y2}} = pl[[pos]];
		If[TrueQ[front],
			Line[Prepend[Drop[line,pos],
				{pt,(y2 - y1)/(x2 - x1) (pt - x1) + y1}]],
			Line[Append[Drop[line,-(Length[line] - pos)],
				{pt,(y2 - y1)/(x2 - x1) (pt - x1) + y1}]]]
	]

End[]

EndPackage[]
