[From Max]
[From Max]
In[]:=
<<SetReplace`
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],VertexLabelsAutomatic]
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},fixedLHSModule[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(#&),VertexLabelsAutomatic]
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}},VertexLabelsAutomatic]
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(#&),VertexLabelsAutomatic]
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}},VertexLabelsAutomatic]
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.
(b)
(b)
(c)
(c)
This one takes a while.
PS. Did the colors get mixed up in the book?
(d)
(d)
SW additions
SW additions
Basic idea: each ternary hyperedge has {exprlabel, headpointer, argpointer}
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]
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....
There is a special “root” vertex, and special “leaf” vertices....
Localized Combinator Literals (the case of S)
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.....