SetOptions[$Output,PageWidth->55] ;

Off[General::spell1] ;

Needs["Utilities`FilterOptions`"] ;
Needs["Graphics`Colors`"] ;

Options[DrawExpression]=
	{deltaX->1, deltaY->2, xMargin->1.1, yMargin->1.2, 
	style->Automatic, title->None} ;

DrawExpression[expr_,options___Rule]:=
	Module[{texpr=expr, g, x, y, dx, dy, xmin, xmax, ymin, ymax, 
			optlist, delx, dely, xm, ym, exprTitle, 
			styles, p, st, op, showOptions},
		optlist={options} // Flatten ;
		delx=deltaX /. optlist /. Options[DrawExpression] ;
		dely=deltaY /. optlist /. Options[DrawExpression] ;
		xm=xMargin /. optlist /. Options[DrawExpression] ;
		ym=yMargin /. optlist /. Options[DrawExpression] ;
		styles=style /. optlist /. Options[DrawExpression] ;
		If[styles=!=Automatic && Head[styles]=!=List, 
			Message[DrawExpression::style,styles] ;
			Return[$Failed]] ;
		For[i=1, i<=Length[styles], i++, 
			If[Length[styles[[i]]]!=2,
				Message[DrawExpression::stprt,i,styles[[i]]] ;
				Return[$Failed]] ;
			{p,st}=styles[[i]] ;
			p=If[Head[p]=!=List,{p},p] ;
			st=If[Head[st]=!=List,{st},st] ;
			op=texpr[[Sequence@@p]] ;
			If[Head[op]===$g, 
				st=Append[First[op],st] ;
				op=Last[op]] ;
			texpr=ReplacePart[texpr, $g[st,op], p]
			] ;
		exprTitle=title /. optlist /. Options[DrawExpression] ;
		showOptions=FilterOptions[Graphics,Sequence@@optlist] ;
		g=Last@DrawExpression[texpr,0,0,delx,dely] ;
		If[exprTitle=!=None,
			g=Prepend[g,Text[exprTitle,{0,4}]]] ;
		{x,y}=(g[[Sequence@@#]]& /@ 
			Position[g,{_?NumberQ,_?NumberQ}]) // Transpose ;
		dx=((xmax=Max[x])-(xmin=Min[x])) xm ;
		dy=((ymax=Max[y])-(ymin=Min[y])) ym ;
		xmin=(xmin+xmax-dx)/2 ; xmax=xmin+dx ;
		ymin=(ymin+ymax-dy)/2 ; ymax=ymin+dy ;
		Show[Graphics[g],
			showOptions, 
			PlotRange->{{xmin,xmax},{ymin,ymax}},
			AspectRatio->Automatic
			]
		]
DrawExpression[$g[dir_,expr_],args__]:=
	Module[{w, g}, 
		{w, g}=DrawExpression[expr,args] ;
		{w, If[Head[g]===List, Join[dir,g], Append[dir,g]]}
		]
DrawExpression[p_[c__],x_,y_,dx_,dy_]:=
	Module[{text=ToString[p], xw, d, xc, xn, gc, xp, yp},
		{xw,gc}=(DrawExpression[#,0,y-dy,dx,dy]& /@ 
			{c}) // Transpose ;
		tw=Plus@@xw ;
		d=FoldList[Plus,0,Drop[xw,-1]]+xw/2 ;
		xc=x-tw/2 + d ;
		tw=Max[tw,Length@Characters[text]] ;
		{tw+1,Join[Prepend[Line[{{x,y-0.6},{#,y-dy+0.6}}]& /@ xc,
				Text[text,{x,y}]],
			MapThread[(#1 /. {{xp_?NumberQ,yp_?NumberQ}:>{xp+#2,yp}})&,
				{gc,xc}]
			]}
		]
DrawExpression[p_?AtomQ,x_,y_,dx_,dy_]:=
	Module[{text=ToString[p]},
		{Length@Characters[text]+1,Text[ToString[text],{x,y}]}
		]