New ways to interact with graphics

Christopher Carlson

Wolfram Research, Inc.

You can interact with Mathematica graphics ...

By Drawing and Dragging

On The Command Line

Using Custom Typesetting Rules

Via Graphics Palettes

By Hiding Information in Graphics

Using Manipulate

Using Controls and Dynamic

Using Locator

DIY Using Event Handler

Using Sound

Using Sprites

With Self-Triggering Dynamics

Via Controllers

Drawing and Dragging

Ctl-1 inserts a blank graphic.

Ctl-t reveals the drawing tools.

Double-click primitive to reshape.
Press shift for constraints.
Select a primitive to draw a new one with the same attributes.

Graphics On The Command Line

Graphics is no longer a side-effect.  Show is no longer necessary.  Watch those semicolons!

ParametricPlot[{Cos[a],Sin[2 a]},{a,0,2π}]

Graphical output is equivalent to its symbolic form, so you can operated on it symbolically.  Type /. Line->Polygon after the graphic and evaluate.  Or, to see how adaptive sampling is working, /. Line[x_] :> Point /@ x .

Since graphics is not a side-effect, you can easily make lists and tables of graphics.

Table[ParametricPlot[{Cos[i a],Sin[j a]},{a,0,2π}], {i,1,3},{j,1,5}]//Grid

... And tables of 3D graphics, each of which is rotatable.

Grid[Table[SphericalPlot3D[Cos[n θ]Sin[m ϕ],{θ,0,Pi},{ϕ,0,2Pi}],{n,1,2},{m,1,3}]]

Graphics are not limited to appearing in Grids; any typeset structure can contain graphics.

Custom Typesetting Rules

Performing math a graphic is a cute demo, but what's the use of that?

Plot[x,{x,-1,1}]

You can give meaning to the square of a plot via a definition for Power.

Unprotect[Graphics];

Graphics /:
Power[g_Graphics, exp_] :=
Normal[g]/.{Line[pts:{_, _, ___}] :> Line[N[({First[#],Power[Last[#],exp]}&) /@ pts]]};

Protect[Graphics];

Now we can take squares and square roots, as well as multiply graphics.

This undoes the previous definition.

Unprotect[Graphics];

Graphics /:
Power[g_Graphics, exp_] =.;

Protect[Graphics];

Custom Typesetting Rules (Cont'd)

Here is a more elaborate example of custom typesetting rules.  These rules define a graphical output and input format for Mathematica expressions themselves.

DefineDiagramForm[]

DiagramForm is a wrapper that triggers typesetting rules that map Mathematica expressions to graphical representations.

{1,2,3,4}//DiagramForm

Here's what the quadratic formula looks like in DiagramForm.

((-b ±(Sqrt[(b^2)-4 a c]))/(2a))//DiagramForm

You can rewire the diagram by swapping the output of Times from the input of Plus with an input of Power.  Use DiagramForm to yield a new, cleaned-up diagram.

You can use DiagramForm to demonstrate graphically the effect of operations like Transpose that restructure expressions.  After output, type // Transpose.

$Post = DiagramForm;

Table["x",{4},{2}]

Thread:  After output, type // Thread.

f[{a,b,c}]

$Post =.

ClearDiagramForm[]

Graphics Palettes

Since the symbolic expression corresponding to an image is stored in the front end, the kernel can retrieve it and operate upon it.  This makes it possible to make palettes that operate on graphics.

ClearDiagramForm[]

MakePolygonPalette[funcs_] :=
NotebookPut[Notebook[{Cell[BoxData[ToBoxes[Pane[Grid[Map[
With[{rules = {(h:(PolygonBox|Polygon3DBox))[x_]:>With[{y=#[x]},h[y]/;True]},pts = {{0,0},{1,0},{1,1},{0,1}}},
Button[Graphics[{
FaceForm[{Magenta,Opacity[.5]}],Polygon[pts],
FaceForm[{Red,Opacity[.5]}],EdgeForm[Black],Polygon[#[pts]]
},ImageSize->50,PlotRange->{{-.3,1.3},{-.3,1.3}}],
NotebookWrite[InputNotebook[],NotebookRead[InputNotebook[]]/.rules,After];
SelectionMove[InputNotebook[], Previous, Graphics]
]]&,funcs,{2}]],ImageMargins->10]]],CellMargins->0]},
WindowFrame->"Palette",WindowTitle->"Polygon Operations",WindowClickSelect->False,Background->Automatic,ShowCellBracket->False,WindowElements->{},WindowFrameElements->{"CloseBox"},WindowFloating->True, ClosingSaveDialog->False,WindowSize->Fit,CacheGraphics->False,DynamicUpdating->True]]

MakePolygonPalette[{{
Module[{c = (Plus @@ #)/Length[#]},(1/(Sqrt[2])# + (1-1/(Sqrt[2]))c)& /@ #]&,
Module[{c = (Plus @@ #)/Length[#]},((-2 c+(Sqrt[2]) c+2 #)/(Sqrt[2]))& /@ #]&
},
{
((# + RotateLeft[#])/2)&,
Module[{c = (Plus @@ #)/Length[#], mids = (# + RotateLeft[#])/2},mids =(.5# + .5c)& /@ mids;
Flatten[Transpose[{#,mids}],1]]&
}
}];

Module[{n=5,l=1./(1+(Sqrt[2])),s=(1./(1+(Sqrt[2])))/(Sqrt[2])},
octagonPts = {{s,0},{s+l,0},{1,s},{1,s+l},{s+l,1},{s,1},{0,s+l},{0,s}};
squarePts = {{1,1-s},{1+s,1},{1,1+s},{1-s,1}};
Graphics[{
Opacity[.7],
EdgeForm[White],
Black,Table[Polygon[(# + {x,y})& /@ octagonPts],{x,0,n-1},{y,0,n-1}],
Magenta,Table[Polygon[(# + {x,y})& /@ squarePts],{x,0,n-2},{y,0,n-2}]
},
PlotRange->{{0,n},{0,n}}]
]

PolyhedronData["TruncatedOctahedron","Image"]//Normal

Hiding Information in Graphics

Wrappers such as Tooltip can be used in graphics as well as in typeset structures.

Graphics[{
Tooltip[{Yellow,Disk[{0,0}]},"Yellow"],
Tooltip[{Red,Disk[{3,0}]},"Red"],
Tooltip[{Blue,Disk[{6,0}]},"Blue"]
}]

Some of the built-in packages have been upgraded for 6.0 using this technique.

<<Miscellaneous`WorldPlot`

WorldPlot[{Africa,RandomColors}]

The same information can be made more subtly available via StatusArea.  Type /. Tooltip -> StatusArea after the graphic.

Any graphics primitive can be made into a button or hyperlink.  With a simple replacement, your map becomes an almanac.

WorldPlot[{Africa,RandomColors}]/. {Tooltip[polygon_, name_]:>Tooltip[Hyperlink[polygon,"http://en.wikipedia.org/wiki/"<>name],name]}

Manipulate

You have seen or will see plenty of examples of manipulate at this conference, so I won't belabor the point.  Manipulate is extremely useful.  I use it every day.

I will take the opportunity instead to show that text is treated as a first-class citizen of graphics that responds to rotation.

Manipulate[Graphics[{Opacity[.5],Table[Rotate[Translate[Rotate[Text[Style[digit,FontSize->192,FontFamily->"Times"],{0,0}],rotation,{0,0}],{offset,0}],r,{0,0}],{r, 0, 2π-0.01,2π/symmetry}]},PlotRange->1],{{digit,2},0,9,1},{{symmetry,19},3,24,1},{{rotation,1.294},0,2π},{{offset,.634},-.75,.75}]

Rotated text is editable.

Graphics[Table[Text[Style[Sqrt[Mathematica],FontSize->30,Italic],{0,0},{-1.5,0},{Cos[a],Sin[a]},ContentSelectable->True],{a,0,2 π-0.01,π/4}],ContentSelectable->True,ImageSize->600]

Controls and Dynamic

Controls work together with Dynamic to make it unthinkably easy to make any part of the Mathematica interface interactive.

Controls can be embedded directly in graphics via Inset.

DynamicModule[{x=1,y=1},
Graphics[{
Rectangle[{0,0},Dynamic[{x,y}]],
Inset[Slider[Dynamic[x],{0,1}],{0,-.5},{-1,0}],
Inset[VerticalSlider[Dynamic[y],{0,1}],{-.5,0},{0,-1}]
},PlotRange->{{-1,2},{-1,2}}]]//Framed

Controls can control their own positions in graphics, meaning you can do some crazy (useful?) things.

DynamicModule[{a = 0,x=0},
Graphics[{
RGBColor[1,0,0],AbsoluteThickness[5],Circle[],
Inset[Slider[Dynamic[a],{0,2π},ImageSize->Small],Dynamic[{Cos[a],Sin[a]}]],
Inset[Slider[Dynamic[x],{-1,1},ImageSize->Medium],Dynamic[{-x,-2}]]
},PlotRange->{{-2,2},{-3,2}}]]//Framed

Someday, controls might even be able to rotate themselves.

DynamicModule[{a = 0},
Style[Graphics[{
RGBColor[1,0,0],AbsoluteThickness[5],Circle[],
Rotate[Text[Slider[Dynamic[a],{0,2π},ImageSize->Small],{0,0},{-1,0}],Dynamic[a],{0,0}]
},PlotRange->2],VectorControls->True]]//Framed

Here's a control that moves itself around in a more useful way.

ShowSignificantPoints[g_, pts_] :=
 Module[{dpt = {-1, -1}},
  ReplacePart[g, 1 -> {g[[1]], 
     DynamicModule[{pt = pts[[1, 1]]}, {
       Arrow[Dynamic[{pt - dpt, pt}]],
       Text[PopupMenu[Dynamic[pt], (First[#] -> Last[#]) & /@ pts], Dynamic[pt - dpt]]
       }]}]
  ]

ShowSignificantPoints[Plot[Sin[x],{x,0,2π},PlotRangePadding->1.25,Method->{"AxesInFront"->False}],{{{3π/2,-1},"Min"},{{π/2,1},"Max"},{{π,0},"Inflection Point"}}]

Locator

Locator is a special control that inhabits graphics.  It functions like a 2D slider, but ranges over the entire graphic, and gives is position in graphics coordinates.

pt={0,0};Dynamic[pt]

Framed[Graphics[Locator[Dynamic[pt]],PlotRange->1]]

Using Locators, you can write draggable, interactive geometry directly.

Deploy[Framed[
DynamicModule[{p1={0,0},p2={1,0},p3={0,1},p4={1,1}},
Graphics[{
Dynamic[{

}],
Locator[Dynamic[p1]],
Locator[Dynamic[p2]],
Locator[Dynamic[p3]],
Locator[Dynamic[p4]]
},PlotRange->{{-1,2},{-1,2}}]
]]]

Varignon's Theorem

Deploy[Framed[
DynamicModule[{p1={Random[],Random[]},p2={Random[],Random[]},p3={Random[],Random[]},p4={Random[],Random[]},pts},
Graphics[{
Dynamic[{
pts = {p1,p2,p3,p4};
Opacity[.8],Gray,
Polygon[pts],
Red,
Polygon[(pts + RotateRight[pts])/2]
}],
Locator[Dynamic[p1]],
Locator[Dynamic[p2]],
Locator[Dynamic[p3]],
Locator[Dynamic[p4]]
},PlotRange->{{0,1},{0,1}}]
]]]

Locators can easily be constrained.

Deploy[DynamicModule[{x=π,y=0},
Graphics[{
{AbsoluteThickness[2],Line[Table[{x,Sin[x]},{x,0,2π,π/32}]]},

Locator[Dynamic[{x,y},(x=First[#];y=Sin[x])&]],

Circle[],Red,Line[Dynamic[{{0,0},{Cos[x],y},{x,y}}]]
},Axes->True,PlotRangePadding->{.1,.2}]
]]

DIY With Event Handler

If all else fails, you can build your own interface from scratch using EventHandler.

ZoomPlot[f_,{x_,xmin0_,xmax0_},opts___]:=
DynamicModule[{dragdisp,xmin,xmax,xrange,yrange,theclick},
dragdisp={};
{xrange,yrange}={{xmin0,xmax0},Automatic};

Column[{
EventHandler[
Dynamic[{xmin,xmax}=xrange;
Show[Plot[f,{x,xmin,xmax},Epilog->Dynamic[dragdisp],opts,ImageSize->Medium],PlotRange->Dynamic[{xrange,yrange}]]],
{
"MouseDown":>(theclick=MousePosition["Graphics"]),

"MouseDragged":>(dragdisp={Opacity[0.1],Rectangle[theclick,MousePosition["Graphics"]]}),

"MouseUp":>({xrange,yrange}=Sort/@Transpose[{theclick,MousePosition["Graphics"]}];dragdisp={})
}],

Button["reset",{xrange,yrange}={{xmin0,xmax0},Automatic},ImageSize->Automatic]
}]]

x=.;

ZoomPlot[x Sin[1/x],{x,-1,1},PlotRange->All,Axes->True]

Sound

With the new Audio`Music package, it is easy to hook up sound to your graphics.  And because Audio`Music` uses your computer's DSP chip, its use doesn't incur any significant computational overhead.

<<Audio`Music`

Manipulate[
PlayMusic[SoundTrack[{SoundNote[note,duration]},"Instrument"->instrument]];
InstrumentNumberToName[instrument],
{instrument,0,127,1},
{{note,64},0,127,1},
{{duration,1},0.01,1}
]

Sound Utilities

Needs["Audio`Music`"]

PlayMusic[SoundTrack[{SoundNote["c5",1/8, 0]}]]

PlaySound[inst_, x___] :=
If[!$SystemSequencer@isRunning[], PlayMusic[SoundTrack[{SoundNote[x]},"Instrument"->inst]]]

Event Handlers

PlayMouseDownSound[tool_] :=
Switch[tool,
_,PlaySound@@{124, 61, .07}
]

PlayMouseDraggedSound[tool_] :=
Switch[tool,
"DrawRectangle",PlaySound@@{"Celesta", 90, 0.027},
"DrawLine",PlaySound@@{"Lead 4 (Chiff)", 88, 0.1245},
"DrawCircle",PlaySound@@{"Bird Tweet", 83, 0.081},
"Select",PlaySound@@{"Tubular Bells", 49, 0.069},
"DrawFreehand",PlaySound@@{"Tinkle Bell", 90, 0.029}
]

PlayMouseUpSound[tool_] :=
Switch[tool,
_,PlaySound@@{123, 61, .07}
]

DynamicModule[{currentTool},
Framed[EventHandler[
Graphics[{},PlotRange->1],
"MouseDown":>(currentTool=CurrentValue[$FrontEnd, "Current2DTool"];PlayMouseDownSound[currentTool]),
"MouseUp":>PlayMouseUpSound[currentTool],
"MouseDragged":>PlayMouseDraggedSound[currentTool],
PassEventsDown->True
]]]

Sprites

Making a Sprite From an Internet Image

butterflyImage = Import["/Users/carlson/Desktop/51892298-M.jpg"]

butterflyRaster =(graphics)[[1]];

Rest[butterflyRaster]

I did a little experimentation to make the background transparent, then plucked the resulting Raster out of the graphic.

Graphics[{
ReplacePart[butterflyRaster, 1->butterflyRaster[[1]]/.{{r_,g_,b_}:>{0,0,0,0}/;(r+g+b > 700),{r_,g_,b_}:>{r,g,b,255}}]//PackRaster
},Background->Green]

butterflySprite = (graphics)[[1]]//PackRaster;

Sprites (Cont'd)

Manipulating Sprites: Transformed Rasters

DynamicModule[{r1=0,s1=.7,tx1=-250,ty1=-250,r2=0,s2=.7,tx2=250,ty2=-250},
Column[{With[{
t1 = Dynamic[{s1{{Cos[r1],-Sin[r1]},{Sin[r1],Cos[r1]}},{tx1,ty1}}],
t2 = Dynamic[{s2{{Cos[r2],-Sin[r2]},{Sin[r2],Cos[r2]}},{tx2,ty2}}]},

Graphics[Nest[{butterflySprite,GeometricTransformation[#,t1],GeometricTransformation[#,t2]}&,butterflySprite,3],PlotRange->1000,ImageSize->600]],

Grid[{
{"rotation",Manipulator[Dynamic[r1],{0,2π}],Manipulator[Dynamic[r2],{0,2π}]},
{"scale",Slider[Dynamic[s1],{0,1}],Slider[Dynamic[s2],{0,1}]},
{"x translation",Slider[Dynamic[tx1],500{-1,1}],Slider[Dynamic[tx2],500{-1,1}]},
{"y translation",Slider[Dynamic[ty1],500{-1,1}],Slider[Dynamic[ty2],500{-1,1}]}}]}]
]

Self-Triggering Dynamics

Dynamics don't have to be connected to controls to be useful.  They can trigger themselves.

DynamicModule[{a=0},
Graphics[{
Red,Disk[Dynamic[If[a < 2π, a += π/32];{Cos[a],Sin[a]}],.25]
},PlotRange->2,Axes->True,GridLines->Automatic]]

spriteData=[[1,1]];

backgroundData=[[1,1]];

Module[{bw,bh,sw,sh,z, pt={4,0},background,frog},
{bh,bw,z}=Dimensions[backgroundData];
{sh,sw,z}=Dimensions[spriteData];
background = Raster[backgroundData,{{0,0},{bw,bh}/150},{0,255}]//PackRaster;
frog = Raster[spriteData,{pt,pt+{1,sh/sw}},{0,255}]//PackRaster;

Style[Graphics[{
background,
DynamicModule[{a=0,x=0},
Button[Translate[frog,Dynamic[{x -= 0.1 If[a >0, a--, 0],If[a>0,.1,0]}]],a=3;Beep[]]
]
},ImageSize->600,PlotRange->{{0,bw/150},{0,bh/150}}],ShowSelection->False]
]

Controllers

And finally, a game that takes advantage of many of these techniques: Manipulate, sprites, sound, self-triggering Dynamics, and the use of a game controller.

RoboSnarf[]

Implementation

Sounds

Needs["Audio`Music`"]

PlayMusic[SoundTrack[{SoundNote["c4",.1,0]}]]

PlaySnarfSound[] := PlayMusic[SoundTrack[{SoundNote[60, .5]},"Instrument"->"Breath Noise"]];

PlayGameOverSound[]:=PlayMusic[SoundTrack[{SoundNote[64-8, 4]},"Instrument"->"Tubular Bells"]]

Geometry

LineHit[p1:{x1_, y1_}, p2:{x2_,y2_}, p:{x_, y_}, ht_] :=
Module[{v12, v1p, v12Mag, v1pMag, proj, dist},
v12 = p2 - p1;v1p = p - p1;
v12Mag = Norm[v12];v1pMag = Norm[v1p];
proj =(v12.v1p)/v12Mag;
dist =(Sqrt[ (v1pMag^2) - (proj^2)]);
Return[0≤proj && proj ≤ v12Mag && dist ≤ ht]
]

MoveBall[bpt_,br_,bv_,spt_,sv_] :=
Module[{bpt2, uv},
bpt2 = bpt+bv;
uv = bv / Norm[bv];
{bpt2, bv, LineHit[bpt-br uv, bpt2 + br uv, spt + br sv, br]}
]

ResetBall[hx_, br_, iv_] :=
Module[{bv = iv},
{{-hx + Random[](2 hx), hx+2br},bv, iv + {0,-.012}}
]

GetSnarferAim[l1_,l2_,l3_,a1_,a2_,a3_]:=
Module[{a12 = a1+a2,a123=a1+a2+a3},
{l1 {Cos[a1],Sin[a1]}+l2{Cos[a12],Sin[a12]}+l3 {Cos[a123],Sin[a123]}, {Cos[a123],Sin[a123]}}
]

Sprites

Arm3D[r1_, r2_, l_] :=Module[{da = π/64,x,y},
x = r1^2/l;
y = r1(Sqrt[l^2-r1^2])/l;
{EdgeForm[None],Sphere[{0,0,0}, r1],
Table[Polygon[{{x,y Cos[a],y Sin[a]},{x,y Cos[a+da],y Sin[a+da]},{l,r2 Cos[a+da],r2 Sin[a+da]},{l,r2 Cos[a],r2 Sin[a]}}], {a, 0,π-0.001,da}],
Polygon[{{0,-r1,0},{0,r1,0},{l, r2,0},{l,-r2,0}}]}
];

Arm[r1_, r2_, l_, col_, scol_, sexp_] :=
Module[{armImage},
armImage = Rasterize[Graphics3D[{col, Specularity[scol, sexp], Arm3D[r1, r2, l]}, ViewPoint -> {0, 0, Infinity}, Boxed -> False, Lighting -> {GrayLevel[0], {White, ImageScaled[{-0.57, -0.23, 1}]}},ImageSize->360]][[1]];
Raster[armImage[[1]]/.{{255,255,255}:>{255,255,255,0},{r_,g_,b_}:>{r,g,b,255}}, {{-r1,-r1},{l,r1}},{0,255},ColorFunction->RGBColor]//PackRaster
]

Ball3D[r_] :=Sphere[{0,0,0}, r];

Ball[radius_, col_, scol_, sexp_] :=
Module[{ballImage},
ballImage = Rasterize[Graphics3D[{col, Specularity[scol, sexp], Ball3D[radius]}, ViewPoint -> {0, 0, Infinity}, Boxed -> False, Lighting -> {GrayLevel[0.25], {White, ImageScaled[{-0.57, .25, 1}]}},ImageSize->30]][[1]];
Raster[ballImage[[1]]/.{{255,255,255}:>{255,255,255,0},{r_,g_,b_}:>{r,g,b,255}}, {{-radius,-radius},{radius,radius}},{0,255},ColorFunction->RGBColor]//PackRaster
]

Sprite Tuning

Manipulate[
Show[Graphics[Arm[1,.7,6,col,scol,n]],ImageSize->100],
{col, Hue[.2]},
{scol, White},
{{n,100},10,100}
]

Manipulate[
Show[Graphics[Ball[.5,col,scol,n]],ImageSize->20],
{col, Hue[.2]},
{scol, White},
{{n,100},10,100}
]

RoboSnarf

RoboSnarf[] :=Module[{pr=13,l1=6,l2=4,l3=4, br = .5, bv,iv={0,-.07},wasSnarfed,spt, sv, p,nSnarfed=0,gameOver = False,arm1,arm2 ,arm3,ball},
arm1= Arm[1,.7,l1,RGBColor[1., 0.69, 0.14],RGBColor[1., 1, 0.14],100];
arm2 = Arm[.7,.5,l2,RGBColor[1., 0.69, 0.14],RGBColor[1., 1, 0.14],100];
arm3 = Arm[.5,.5,l3,RGBColor[1., 0.69, 0.14],RGBColor[1., 1, 0.14],100];
ball = Ball[.5,RGBColor[1., 0., 0.12],RGBColor[0.86, 0.61, 0.],10];
{p, bv, iv} = ResetBall[pr, br, iv];
DynamicModule[{bpt = p},
Manipulate[
Graphics[{
Rotate[{arm1,
Translate[Rotate[{arm2,
Translate[Rotate[arm3,Dynamic[-a3],{0,0}],{l2,0}]
},Dynamic[-a2],{0,0}],{l1,0}]},Dynamic[a1], {0,0}],
Translate[ball,Dynamic[
If[!gameOver,
If[bpt[[2]] - br < -pr,
(* Game Over*)
gameOver = True;
PlayGameOverSound[],
(* Else *)
{spt, sv} = GetSnarferAim[l1,l2,l3,a1,-a2,-a3];
{bpt, bv, wasSnarfed} = MoveBall[bpt,br,bv,spt, sv]; 
If[wasSnarfed, nSnarfed++;PlaySnarfSound[];{bpt, bv, iv}=ResetBall[pr, br, iv]]]];
bpt]],
Text[Style[Dynamic[nSnarfed],FontFamily->"Helvetica",FontSize->36,FontColor->If[gameOver,Red,Black]],{0,-pr},{0,-1.5}]
},PlotRange->pr],"Y1Cyclic"->{{a1,π/2}, -2π, 2π},
"X1Cyclic"->{{a2,π}, -2π,2 π},"X2Cyclic"->{{a3,π}, -2π, 2π},ControlType->None]]
]

Initialization

PackRaster

PackRaster[Raster[data_,rest___]] :=
Raster[Developer`ToPackedArray[data],rest]

DiagramForm: ExpressionToGraphics[]

ClearAll[ExpressionToGraphics];

ExpressionToGraphics[expr_] :=
Block[{graphics, xMin, xMax, yMin,yMax,hBoxMargin,vBoxMargin,minTextWidth,minTextHeight,vInputSpacing,hInputLength,hBoxSpacing,vBoxSpacing, leafBoxColor,headBoxColor},
hBoxMargin = 5;
vBoxMargin = 3;
minTextWidth = 10;
minTextHeight = 12;
vInputSpacing = 5;
hInputLength = 12;
hBoxSpacing = 50;
vBoxSpacing = 5;
boxPointLength = 8;
leafBoxColor = RGBColor[1,.7,1];
headBoxColor = RGBColor[1,.7, .4];

graphics = ExpressionToGraphics0[expr];
{{xMin, xMax},{yMin,yMax}} = PlotRange /. Options[graphics];
Join[graphics, Graphics[ImageSize->{xMax-xMin, yMax-yMin}, AspectRatio->Automatic]]
]

ClearAll[ExpressionToGraphics0];

ExpressionToGraphics0[a_?AtomQ] :=
Module[{textWidth, textHeight},
{textWidth, textHeight} = getSizeOfText[a];
	Graphics[{
	leafBoxColor,
	(* Order of points is crucial to proper parsing Polygon[{{-2 textWidth,-textHeight},{-textWidth,-2 textHeight},{0,-textHeight},{-textWidth, 0}}],
*)
	Polygon[{{-textWidth-boxPointLength, -textHeight/2},{-textWidth,0},{0,0},{boxPointLength, -textHeight/2},{0,-textHeight},{-textWidth,-textHeight}}],
	GrayLevel[0],
Text[a, {-textWidth/2.,-textHeight/2.}]
}, PlotRange->{{-textWidth-boxPointLength,boxPointLength},{-textHeight,0}}]
];

ExpressionToGraphics0[f_[e___]] :=
Module[{inputGraphics,xMin, xMax, yMin, yMax,width, height,nInputs,textWidth,textHeight},
{inputGraphics, {{xMin,xMax},{yMin, yMax}}} =
arrangeInputs[ExpressionToGraphics0 /@ {e}, vBoxSpacing];
nInputs = Length[{e}];
{textWidth, textHeight} = getSizeOfText[f];
width = Max[textWidth, minTextWidth] + 2 hBoxMargin;
height = Max[(Max[nInputs, 1] + 1) vInputSpacing, minTextHeight] + 2 vBoxMargin;
xMinHead = xMax + hBoxSpacing;
xMaxHead = xMinHead + width;
yMaxHead = yMax - ((yMax - yMin)-height)/2;
yMinHead = yMaxHead - height;
yMaxInput = (yMaxHead+yMinHead + (nInputs - 1) vInputSpacing)/2;
Graphics[{
First /@ inputGraphics,
Table[
Line[{{xMax, Plus @@ #[[2]]/2}&[ PlotRange /. Options[inputGraphics[[i]]] ],{xMinHead, yMaxInput - (i-1) vInputSpacing}}], {i, 1,nInputs}
] /. {Line[{{x1_, y1_},{x2_,y2_}}] :> Line[{{x1,y1},{x1 + hInputLength, y1},{x2 - hInputLength, y2},{x2,y2}}]},
				translateGraphics[{
						headBoxColor,
						(* Order of points is crucial to proper parsing *)
						Polygon[{{-width, -height},{-width, 0},{0,0},{0,-height},{-width, -height}}],
						GrayLevel[0],
						Text[f, {-width/2.,-height/2.}]
					}, {width + hBoxSpacing, -(yMax - yMin - height)/2}]
			},
			PlotRange->{{xMin, width + hBoxSpacing}, {Min[yMin, (yMin - yMax -height)/2], yMax}}
		]
	];

ClearAll[getSizeOfText];

getSizeOfText[expr_] :=
Module[{boxWidth, boxHeight, boxDepth,fontSize},
(* Workaround bug: 
GetBoundingBoxSizePacket doesn't respect setting
of the style environment. *)
(* Workaround bug in workaround: "Options" should be "AbsoluteOptions", but that function is horribly leaky and slow *)
fontSize = FontSize/.Options[EvaluationNotebook[],FontSize];

{{{boxWidth, boxHeight, boxDepth}}} = {
LinkWrite[$ParentLink, FrontEnd`GetBoundingBoxSizePacket[Cell[BoxData[StyleBox[ToBoxes[expr],FontSize->fontSize]],"Output"]]];
LinkRead[$ParentLink]
};
{boxWidth, boxHeight+boxDepth}
]

DiagramForm: arrangeInputs[]

Positions the elements of a list of Graphics[] so that the rhs of their bounding boxes are at x=0, the top of the first is at y=0, and the rest descend downward with vSpacing units inbetween each.  Returns a doublet containing a list of the arranged graphics and the bounding box of the graphics.

ClearAll[arrangeInputs];

arrangeInputs[g:{_Graphics...}, vSpacing_] :=
	arrangeInputs[g, vSpacing, {}, {{0,0},{0,0}}];

arrangeInputs[{},  _, g_, bbox_] := {g, bbox};

arrangeInputs[gIn:{__},  vSpacing_, gOut_List,
	{{xMinBBox_, xMaxBBox_},{yMinBBox_,yMaxBBox_}}
] :=
	Module[{xMin, xMax,yMin,yMax, g, dy},
		dy = If[gOut == {}, 0, vSpacing];
		{{xMin, xMax},{yMin,yMax}} = PlotRange /. Options[First[gIn]];
		g =  translateGraphics[First[gIn], {-xMax, -yMax +yMinBBox-dy}];
		{{xMin, xMax},{yMin,yMax}} = PlotRange /. Options[g];
		arrangeInputs[Rest[gIn], vSpacing,
			Append[gOut,g],{{Min[xMin, xMinBBox],xMaxBBox},{ yMin, yMaxBBox}}
		]
	];

translateGraphics[g_, d_] :=
	g /.{
			Point[pt_] :> Point[pt+d],
			Line[pts_] :> Line[(# + d)& /@ pts],
			Polygon[pts_] :> Polygon[(# + d)& /@ pts],
			Text[t_,pt_] :> Text[t, pt + d],
			Rectangle[pt1_, pt2_] :> Rectangle[pt1 + d, pt2 + d],
			Circle[pt_, r_] :> Circle[pt + d, r],
			HoldPattern[PlotRange->r_]:>PlotRange->r+d
		};

DiagramForm: GraphicsToExpression

ClearAll[GraphicsToExpression];

GraphicsToExpression[g:GraphicsBox[___]] :=
Module[{text, nFunctionRects, labeledRects, lines, parentChildArcs, parentChildMultiArcs},
(* Make a list of labeled bounding box rectangles *)
(* Processing of text is a hack that makes a shaky assumption about the form of the first argument. *)
text = Cases[g, InsetBox[e_,pt_, opts___]:>InsetBox[ToExpression[e], pt, opts], {1, ∞}];
labeledRects =labelRects[text, 
Cases[g, PolygonBox[{{x1_,y1_},{x2_,y2_}, {x3_, y3_}, {x4_, y4_}, {x5_, y5_}}]:>
{Interval[{x1,x3}],Interval[{y1,y3}]}, {1, ∞}]];
nFunctionRects = Length[labeledRects];
labeledRects =
Join[labeledRects,
labelRects[text,
Cases[g, PolygonBox[{{x1_,y1_},{x2_,y2_},{x2a_, y2a_},{x3_, y3_}, {x4_, y4_},{x4a_,y4a_}}]:>{Interval[{x1,x3}],Interval[{y2,y4}]},  {1,∞}]]];
(* Find out which rects are joined by which lines *)
lines = Cases[g, LineBox[{{x1_,y1_},___,{xn_,yn_}}]->{{x1,y1},{xn,yn}}, {1, ∞}];
parentChildArcs = findParentChildArcs[lines, labeledRects, 0.01];
parentChildMultiArcs = findParentChildMultiArcs[parentChildArcs];

(* Build the expression from the arcs and text information *)
buildExpression[parentChildMultiArcs, findMultiArcsRoot[parentChildMultiArcs],
(#[[3]])& /@ labeledRects, nFunctionRects]
];

labelRects[text_, rects_] :=Module[
		{xInterval = #[[1]], yInterval = #[[2]]},
		Append[#,
			Select[text, 
				(IntervalMemberQ[xInterval, #[[2,1]]] && 
					IntervalMemberQ[yInterval, #[[2,2]]])&, 1][[1,1]]
			]
	]& /@ rects;

findParentChildArcs[lines_, rects_, slop_] := Module[
		{x1 = #[[1,1]], y1 = #[[1,2]], x2 = #[[2,1]], y2 = #[[2,2]]},
		{
			Position[rects, 
				_?((IntervalMemberQ[#[[2]], y2] && IntervalMemberQ[#[[1]], (x2 + slop)])&), 
				{1}, 1, Heads->False][[1,1]],
			Position[rects, 
				_?((IntervalMemberQ[#[[2]], y1] && IntervalMemberQ[#[[1]], (x1 - slop)])&), 
				{1}, 1, Heads->False][[1,1]],
				y2
		}
		]& /@ lines;

findParentChildMultiArcs[arcs_] := Module[{sortedArcs, maxIndex},
		sortedArcs = 
			Sort[arcs, (First[#1]<First[#2] || (First[#1]==First[#2] && Last[#1]>Last[#2]))&];
		maxIndex = Max @@ Flatten[Drop[#,-1]& /@ arcs];
		Fold[Insert[#1, #2[[2]], {#2[[1]],-1}]&, Table[{}, {maxIndex}], sortedArcs]
	];

findMultiArcsRoot[arcs_] := 
	First[Complement[Range[Length[arcs]], Sequence @@ arcs]];

buildExpression[multiArcs_, rootIndex_, text_, nFunctions_]:= 
	If[rootIndex > nFunctions,
		text[[rootIndex]],
		text[[rootIndex]] @@
			(buildExpression[multiArcs, #, text, nFunctions]& /@ multiArcs[[rootIndex]])
	];

DiagramForm: MakeBoxes[] and MakeExpression[]

DefineDiagramForm[]:=
(
MakeBoxes[DiagramForm[e_],form_]:=MakeBoxes[#,form]&@@{ExpressionToGraphics[e]};
Unprotect[GraphicsBox];
MakeExpression[g:GraphicsBox[__],form_]^:=HoldComplete@@{GraphicsToExpression[g]};
FormatValues[GraphicsBox]=RotateRight[FormatValues[GraphicsBox]];
Protect[GraphicsBox];
)

ClearDiagramForm[] :=
(
MakeBoxes[DiagramForm[e_], form_] =.;
Unprotect[GraphicsBox];
GraphicsBox/:MakeExpression[g:GraphicsBox[__], form_] =.;
Protect[GraphicsBox];
$Post =.
)