[From Max]

In[]:=
<<SetReplace`
LibraryFunction
:The function setCreate has already been loaded with argument types {{Integer,1},{Integer,1},{Integer,1},Integer}. The new function will be an overload for different types.
In[]:=
Quiet[makePattern[var_]:=Pattern[var,Blank[]],RuleDelayed::rhs]
In[]:=
sowExpressions[e_,root_,makePatterns_]:=Module[{part,expr,finalPart,finalExpr},​​If[root=!=Automatic,part=root];​​If[AtomQ[e]||MatchQ[e,_Pattern],expr=e];​​If[makePatterns,​​finalPart=makePattern[part];​​If[!AtomQ[e]&&!MatchQ[e,_Pattern],finalExpr=makePattern[expr],finalExpr=expr];,​​finalPart=part;​​finalExpr=expr;​​];​​Sow[{finalPart,finalExpr}];​​If[!AtomQ[e]&&!MatchQ[e,_Pattern],Sow[Join[{finalExpr,sowExpressions[Head[e],Automatic,makePatterns]},sowExpressions[#,Automatic,makePatterns]&/@List@@e]]];​​finalPart​​]
In[]:=
expressionToHypergraph[expr_,root_,makePatterns_:False]:=Reap[sowExpressions[expr,root,makePatterns]]〚2,1〛
In[]:=
WolframModelPlot[expressionToHypergraph[s[k][s[k]],root],VertexLabelsAutomatic]
Out[]=
In[]:=
expressionToSetSubstitutionRule[left_right_]:=Module[{lhs,rhs,newVariables},​​lhs=expressionToHypergraph[left,ruleRoot,True];​​rhs=Join[DeleteCases[lhs/.Pattern(#&),{ruleRoot,_}],expressionToHypergraph[right,ruleRoot,False]];​​newVariables=Complement@@Union/@Catenate/@{rhs,lhs/.Pattern(#&)};​​With[{fixedLHS=lhs,fixedNewVariables=newVariables,fixedRHS=rhs},​​fixedLHSModule[fixedNewVariables,fixedRHS]​​]​​]
In[]:=
expressionToSetSubstitutionRule[k[x_][y_]x]
Out[]=
{{ruleRoot_,expr$68184_},{part$68185_,expr$68185_},{part$68186_,k},{part$68187_,x_},{expr$68185_,part$68186_,part$68187_},{part$68188_,y_},{expr$68184_,part$68185_,part$68188_}}Module[{},{{part$68185,expr$68185},{part$68186,k},{part$68187,x},{expr$68185,part$68186,part$68187},{part$68188,y},{expr$68184,part$68185,part$68188},{ruleRoot,x}}]
PS. I’m aware that WolframModelPlot fails dramatically if evaluated on expressions containing patterns: #497.
In[]:=
WolframModelPlot[{{ruleRoot_,expr$68184_},{part$68185_,expr$68185_},{part$68186_,k},{part$68187_,x_},{expr$68185_,part$68186_,part$68187_},{part$68188_,y_},{expr$68184_,part$68185_,part$68188_}}/.Pattern(#&),VertexLabelsAutomatic]
Out[]=
In[]:=
WolframModelPlot[{{part$68185,expr$68185},{part$68186,k},{part$68187,x},{expr$68185,part$68186,part$68187},{part$68188,y},{expr$68184,part$68185,part$68188},{ruleRoot,x}},VertexLabelsAutomatic]
Out[]=
In[]:=
expressionToSetSubstitutionRule[s[x_][y_][z_]x[z][y[z]]]
Out[]=
{{ruleRoot_,expr$68354_},{part$68355_,expr$68355_},{part$68356_,expr$68356_},{part$68357_,s},{part$68358_,x_},{expr$68356_,part$68357_,part$68358_},{part$68359_,y_},{expr$68355_,part$68356_,part$68359_},{part$68360_,z_},{expr$68354_,part$68355_,part$68360_}}Module[{expr$68361,expr$68362,expr$68365,part$68362,part$68363,part$68364,part$68365,part$68366,part$68367},{{part$68355,expr$68355},{part$68356,expr$68356},{part$68357,s},{part$68358,x},{expr$68356,part$68357,part$68358},{part$68359,y},{expr$68355,part$68356,part$68359},{part$68360,z},{expr$68354,part$68355,part$68360},{ruleRoot,expr$68361},{part$68362,expr$68362},{part$68363,x},{part$68364,z},{expr$68362,part$68363,part$68364},{part$68365,expr$68365},{part$68366,y},{part$68367,z},{expr$68365,part$68366,part$68367},{expr$68361,part$68362,part$68365}}]
In[]:=
WolframModelPlot[{{ruleRoot_,expr$68354_},{part$68355_,expr$68355_},{part$68356_,expr$68356_},{part$68357_,s},{part$68358_,x_},{expr$68356_,part$68357_,part$68358_},{part$68359_,y_},{expr$68355_,part$68356_,part$68359_},{part$68360_,z_},{expr$68354_,part$68355_,part$68360_}}/.Pattern(#&),VertexLabelsAutomatic]
Out[]=
In[]:=
WolframModelPlot[{{part$68355,expr$68355},{part$68356,expr$68356},{part$68357,s},{part$68358,x},{expr$68356,part$68357,part$68358},{part$68359,y},{expr$68355,part$68356,part$68359},{part$68360,z},{expr$68354,part$68355,part$68360},{ruleRoot,expr$68361},{part$68362,expr$68362},{part$68363,x},{part$68364,z},{expr$68362,part$68363,part$68364},{part$68365,expr$68365},{part$68366,y},{part$68367,z},{expr$68365,part$68366,part$68367},{expr$68361,part$68362,part$68365}},VertexLabelsAutomatic]
Out[]=
Warning: This rule only works for ternary edges, i.e., expressions with exactly one argument.
In[]:=
duplicationRule={{root_,expr_},{anotherRoot_,expr_},{expr_,head_,arg_},{head_,headExpr_},{arg_,argExpr_}}Module[{duplicateExpr,duplicateHead,duplicateArg},{{root,expr},{anotherRoot,duplicateExpr},{expr,head,arg},{duplicateExpr,duplicateHead,duplicateArg},{head,headExpr},{arg,argExpr},{duplicateHead,headExpr},{duplicateArg,argExpr}}];
Steps are skipped because it needs to duplicate identical expressions in the output.
It does not garbage-collect. So, the rest of the hypergraph are the intermediate results that are no longer needed.
Unless I’m missing something, garbage-collecting will require negated matching #323.
Checking other examples from NKS.

(b)

(c)

This one takes a while.
PS. Did the colors get mixed up in the book?

(d)

SW additions

Basic idea: each ternary hyperedge has {exprlabel, headpointer, argpointer}

Alternative approach: indicate each head element by a self loop, and have only {head, arg}

These are not general hypergraphs ... they are ones generated to reflect tree structure .... AND any shared subtree has to be duplicated [because of the current setup of WM]

There is a special “root” vertex, and special “leaf” vertices....

Localized Combinator Literals (the case of S)

This includes both combinator evaluation events, and S duplication, and subexpression duplication....
The “highway” is the evolution process.....