TraceCausalGraph

Build a causal graph from a trace

DefinitionResourceCreateNotebook

HoldRangeFromAttributes[attrs_, len_] :=
    Which[
        MemberQ[attrs, HoldAll | HoldAllComplete] || ContainsAll[attrs, {HoldFirst, HoldRest}],
        {1, len},
        MemberQ[attrs, HoldFirst],
        {1, 1},
        MemberQ[attrs, HoldRest],
        {2, len},
        True,
        {1, 0}
    ]

HoldRange[sym_Symbol[args___]] := HoldRangeFromAttributes[Attributes[sym], Length[HoldComplete[args]]]
HoldRange[Verbatim[Function][_, _, attrs___][args___]] := HoldRangeFromAttributes[Flatten[{attrs}], Length[HoldComplete[args]]]
HoldRange[___] := {1, 0}

ClearAll[PartialTrace]
SetAttributes[PartialTrace, HoldFirst]
Options[PartialTrace] = Join[{"TraceSteps" -> Infinity, "TraceChanges" -> Automatic}, Options[TraceScan]];

PartialTrace[expr_, opts : OptionsPattern[]] := Block[{
	step = 0, change = 0, t = {}, curExpr, prevExpr, pos = {1},
	maxSteps = OptionValue["TraceSteps"], maxChanges, stack, prevStackLength = 0, stackLength
},
	maxChanges = Replace[OptionValue["TraceChanges"], Automatic :> maxSteps];
	If[maxSteps <= 0 || maxChanges <= 0, Return[{HoldComplete[expr]}]];
	
	StackBegin @ TraceScan[
		StackInhibit[
			stack = Stack[_];
			stackLength = Length[stack] - 1;
			(*EchoLabel[{"begin", event, stack[[2 ;;]]}][#];
			Echo[t];*)
			If[stackLength == prevStackLength && Last[stack] =!= prevExpr || stackLength > prevStackLength, change++];
			If[change >= maxChanges, t = Insert[t, {HoldComplete[TerminatedEvaluation["EventLimit"]]}, pos]; Return[step, TraceScan]];
			curExpr = HoldComplete @@ #;
			If[# === HoldForm[Sequence], t = MapAt[Sequence @@@ HoldComplete[#] &, t, MapAt[# - 1 &, pos, -1]]];
			
			If[ stackLength > prevStackLength , 
				t = MapAt[prev |-> {prev, HoldComplete @@ #}, t, MapAt[# - 1 &, pos, -1]];
				pos = Append[MapAt[# - 1 &, pos, -1], 3];
				,
				If[ stackLength < prevStackLength,
					pos = MapAt[# + 1 &, Most[pos], -1]
				];
				t = Insert[t, curExpr, pos];
				pos = MapAt[# + 1 &, pos, -1];
			];

			step++;
			If[step >= maxSteps, t = Insert[t, HoldComplete[TerminatedEvaluation["StepLimit"]], pos]; Return[step, TraceScan]];
			
			
			prevExpr = Last[stack];
			prevStackLength = stackLength;
		] &,
		expr,
		_,
		StackInhibit[	
			stack = Stack[_];
			stackLength = Length[stack] - 1;
			(*EchoLabel[{"after", event, stack[[2 ;;]]}][Rule[##]];*)
			If[ stackLength < prevStackLength,
				pos = MapAt[# + 1 &, Most[pos], -1]
			];
			prevStackLength = stackLength;
			prevExpr = Last[stack];
		] &,
		Evaluate @ FilterRules[{opts}, Options[TraceScan]]
	];
	Developer`ToList[t[[1]]]
]

tracePath // ClearAll

tracePath[{}, ___] := {}

tracePath[expr_HoldComplete | {expr_HoldComplete}, pos_ : {}] := {pos, expr}

tracePath[trace : {sideTraces : PatternSequence[___List]}, pos_ : {}] := Catenate @ MapIndexed[tracePath[#1, Join[pos, - #2]] &, {sideTraces}];

tracePath[trace : {sideTraces : PatternSequence[___List], holdExpr : HoldComplete[expr___], subTrace___}, pos_ : {}] := Block[{
	holdRange = HoldRange[Unevaluated[expr]],
	unevaluated = Catenate @ Position[Unevaluated[expr], _Unevaluated, {1}, Heads -> False],
	n, partPositions,
	partTraces, nextTrace,
	sidePath, partPaths, nextPath
},
	unevaluated = DeleteElements[unevaluated, Range @@ holdRange];
	If[ MatchQ[Unevaluated[expr], _[___]],
		n = Length[Unevaluated[expr]] + Subtract @@ holdRange - Length[unevaluated];
		partPositions = Complement[Range[0, Length[Unevaluated[expr]]], Union[Range @@ holdRange, unevaluated]],
		
		n = 0;
		partPositions = {}
	];
	sidePath = Catenate @ MapIndexed[tracePath[#1, Join[pos, - #2]] &, {sideTraces}];
	
	{partTraces, nextTrace} = TakeDrop[{subTrace}, UpTo[n]];
	partPositions = Take[partPositions, Length[partTraces]];
	partPaths = MapThread[tracePath[#2, Append[pos, #1]] &, {partPositions, partTraces}];
	
	nextPath = If[Length[nextTrace] > 0,
		(*nextTrace = MapAt[Splice, nextTrace, -1];*)
		tracePath[
			(*because TraceScan doesn't include reconstructed expression if arguments haven't changed*)
			If[ Length[unevaluated] == 0 && AllTrue[partPaths, #[[2]] === #[[-1]] && ! MatchQ[#[[-1]], HoldComplete[]] &](* ||
					EchoEvaluation @ MatchQ[holdExpr, HoldComplete[_Symbol[___]]] && MemberQ[Extract[holdExpr, {1, 0}, Attributes], Flat]*),
				nextTrace,
				If[MatchQ[nextTrace, {_List, ___}], MapAt[Rest, nextTrace, 1], Rest[nextTrace]]
			],
			pos
		],
		{}
	];
	(*If[Length[{subTrace}] < n, Echo[trace]; EchoLabel["Side"][sidePath]; EchoLabel["Parts"][partPaths]; EchoLabel["Next"][nextPath](*Return[If[Length[Unevaluated[{subTrace}]] > 0, Join[sidePath, {pos, holdExpr}, partPaths], Join[sidePath, {pos, holdExpr}]]]*)]*);
	Join[
		sidePath,
		{pos, holdExpr},
		Catenate @ Append[nextPath] @
			Fold[
				Block[{sideTraceQ = MatchQ[#2[[1]], {___, _ ? Negative, ___}], newPath, nextExpr = #1[[1]]},
					newPath = Catenate @ Map[
						Replace[{partPos_List, HoldComplete[part___]} :>
						Which[
							! sideTraceQ && MatchQ[partPos, {___, _ ? Negative, ___}],
							{partPos, HoldComplete[part]},

							True,
							Which[
								Length[HoldComplete[part]] > 1,
								{MapAt[# ;; # + Length[Unevaluated[part]] - 1 &, partPos, -1], nextExpr = (*FlattenAt[{1, #1[[3, 1]]}] @ *)ReplacePart[#1[[1]], {1, #1[[3, 1]]} :> Sequence[part]]},
								Length[HoldComplete[part]] == 0,
								{Most[partPos], nextExpr = (*FlattenAt[{1, #1[[3, 1]]}] @ *)ReplacePart[#1[[1]], {1, #1[[3, 1]]} :> Sequence[]]},
								True,
								{partPos, nextExpr = ReplacePart[#1[[1]], {1, #1[[3, 1]]} :> part]}
							]
						]
						],
						Partition[#2, 2]
					];
					{nextExpr, Append[#1[[2]], newPath], Rest[#1[[3]]]}
				] &,
				{holdExpr, {}, partPositions},
				partPaths
			][[2]]
	]
]

ClearAll[TracePath]

SetAttributes[TracePath, HoldFirst]

Options[TracePath] = Join[{"PruneIdentities" -> True, "PruneSidePaths" -> False}, Options[PartialTrace]];


TracePath[t : {___, _HoldComplete, ___}, patt_, opts : OptionsPattern[]] := SequenceReplace[
	Block[{path = tracePath[t]},
		If[ TrueQ[OptionValue["PruneIdentities"]],
			path = FixedPoint[SequenceReplace[{x_HoldComplete, _, x_HoldComplete} :> x], path]
		];
		If[ TrueQ[OptionValue["PruneSidePaths"]],
			path = SequenceReplace[path, {{___, _ ? Negative, ___}, _HoldComplete} :> Nothing]
		];
		path
	],
	If[ MatchQ[patt, _Rule],
		{HoldComplete[x_], _, HoldComplete[y_]} /; ! MatchQ[Unevaluated[x], patt[[1]]] || ! MatchQ[Unevaluated[y], patt[[2]]] :> HoldComplete[y],
		{_, HoldComplete[x_]} /; ! MatchQ[Unevaluated[x], patt] :> Sequence[]
	]
]

TracePath[expr_, patt_, opts : OptionsPattern[]] := TracePath[Evaluate @ PartialTrace[expr, FilterRules[{opts}, Options[PartialTrace]]], patt, opts]

positionDependQ // ClearAll
positionDependQ[{i_Span, is___}, {j_, js___}] := positionDependQ[{First[i], is}, {j, js}]
positionDependQ[{i_, is___}, {j_Span, js___}] := positionDependQ[{i, is}, {First[j], js}]
positionDependQ[{i_Integer, is___}, {j_Integer, js___}] := Which[
	i >= 0 && j >= 0,
	i == j && positionDependQ[{is}, {js}],
	i < 0 && j < 0,
	i != j || positionDependQ[{is}, {js}],
	True,
	True
]

positionDependQ[___] := True

Options[stateVertexShapeFunction] = {
	"StateStyleOptions" -> {FontWeight -> Bold, FontColor -> Directive[Opacity[1], Black], FontFamily -> "Source Code Pro"},
	"StateFrameOptions" -> {Background -> Directive[Opacity[0.2], ], FrameMargins -> {{2, 2}, {0, 0}}, FrameStyle -> Directive[Opacity[0.5], ], RoundingRadius -> 0}
};

stateVertexShapeFunction[opts : OptionsPattern[]] := With[{
	styleOpts = {OptionValue["StateStyleOptions"], OptionValue[Options[stateVertexShapeFunction], "StateStyleOptions"]},
	frameOpts = {OptionValue["StateFrameOptions"], OptionValue[Options[stateVertexShapeFunction], "StateFrameOptions"]}
},
	Function[Inset[Framed[Style[If[#2[[1]] == 0, "-", HoldForm @@ #2[[2]]], styleOpts], frameOpts], #1, #3]]
]

Options[eventVertexShapeFunction] = {
	"ShowIndices" -> False,  "ShowPositions" -> False, "ShowExpressions" -> True,
	"EventColumnOptions" -> {Alignment -> Center, Background -> {Opacity[0.8, ], }, BaseStyle -> Directive[Opacity[1], Black, Bold, FontFamily -> "Source Code Pro"]},
	"EventStyleOptions" -> {FontColor -> Directive[Opacity[1], Black], FontFamily -> "Source Code Pro"},
	"EventFrameOptions" -> {Background -> Directive[Opacity[0.2], Hue[0.14, 0.34, 1]], FrameMargins -> {{2, 2}, {0, 0}}, FrameStyle -> Hue[0.09, 1, 0.91, .3]},
	"SideEventFrameOptions" -> {Background -> Directive[Opacity[0.2], Hue[0.14, 0.34, 1]], FrameMargins -> {{2, 2}, {0, 0}}, FrameStyle -> Directive[Black, Dashed]}
};

eventVertexShapeFunction[opts : OptionsPattern[]] := With[{
	colOpts = {OptionValue["EventColumnOptions"], OptionValue[Options[eventVertexShapeFunction], "EventColumnOptions"]},
	eventOpts = {OptionValue["EventStyleOptions"], OptionValue[Options[eventVertexShapeFunction], "EventStyleOptions"]},
	frameOpts = {OptionValue["EventFrameOptions"], OptionValue[Options[eventVertexShapeFunction], "EventFrameOptions"]},
	sideFrameOpts = {OptionValue["SideEventFrameOptions"], OptionValue[Options[eventVertexShapeFunction], "SideEventFrameOptions"]},
	showIndex = If[TrueQ[OptionValue["ShowIndices"]], Identity, Nothing &],
	showPosition = If[TrueQ[OptionValue["ShowPositions"]], Identity, Nothing &]
},
With[{
	showExpression = If[TrueQ[OptionValue["ShowExpressions"]],
		Function[holdRow @ ReplacePart[#1, #2 -> If[#4 == 0, Column[{"", #3[[-1]]}, colOpts], Column[holdRow /@ #3, colOpts]]]],
		(If[#4 == 0, Column[{"", #3[[-1]]}, colOpts], Column[holdRow /@ #3, colOpts]] &)
	]
},
	Function[
		Replace[#2, DirectedEdge[from_, to_, loc1_ -> loc2_] :> Block[{
			pos1 = Tuples @ Replace[loc1, {span_Span :> Range @@ span, i_ :> {i}}, {1}],
			pos2 = Tuples @ Replace[loc2, {span_Span :> Range @@ span, i_ :> {i}}, {1}],
			upos1, upos2,  
			fromPos, toPos
		},
			upos1 = Union @@ pos1;
			upos2 = Union @@ pos2;
			fromPos = Prepend[1] @ TakeWhile[pos2[[1]], NonNegative];
			toPos = Prepend[1] @ Reverse @ TakeWhile[Reverse[pos2[[1]]], NonNegative];
			Inset[
				Framed[
					Row[{
						If[# === {}, Nothing, Column[{Splice[#], SpanFromAbove}, Alignment -> Top]] & @ {showIndex[from[[1]]], showPosition[loc2]},
						Style[
							Which[
								NoneTrue[upos1, Negative] && NoneTrue[upos2, Negative],
								showExpression[from[[2]], fromPos, {Extract[from[[2]], fromPos, HoldForm], Extract[to[[2]], toPos, HoldForm]}, from[[1]]],
								AnyTrue[upos1, Negative] && NoneTrue[upos2, Negative],
								showExpression[to[[2]], toPos[[;; 1]], {HoldForm @@ from[[2]], Extract[to[[2]], toPos, HoldForm]}, from[[1]]],
								NoneTrue[upos1, Negative] && AnyTrue[upos2, Negative],
								showExpression[from[[2]], fromPos, {Extract[from[[2]], fromPos, HoldForm], HoldForm @@ to[[2]]}, from[[1]]],
								True,
								showExpression[from[[2]], toPos, Thread @ {Extract[from[[2]], toPos, HoldForm], Extract[to[[2]], toPos, HoldForm]}, from[[1]]]
							] /. Verbatim[HoldForm][] :> Sequence[]
						,
						eventOpts
					]}, Spacer[1]],
					If[from[[1]] != 0 && (AnyTrue[upos1, Negative] || AnyTrue[upos2, Negative]), sideFrameOpts, frameOpts]
				]
				, #1, #3
			]
		]]
	]
]]

ClearAll[tracePathGraph, TracePathGraph, traceCausalGraph, TraceCausalGraph]

SetAttributes[{TracePathGraph, TraceCausalGraph}, HoldFirst]

Options[tracePathGraph] = Join[
	{"PruneTerminatedEvaluation" -> True, "HighlightChanges" -> False, "HighlightOptions" -> {FontColor -> Red}},
	Options[stateVertexShapeFunction], Options[Graph]
];

tracePathGraph[initPath_List, opts : OptionsPattern[]] := With[{
	vsf = stateVertexShapeFunction[FilterRules[{opts}, Options[stateVertexShapeFunction]]],
	highlightOpts = {OptionValue["HighlightOptions"], OptionValue[Options[tracePathGraph], "HighlightOptions"]}
},
Block[{path = initPath, vertices, edges},
	If[TrueQ[OptionValue["PruneTerminatedEvaluation"]], path = Select[path, FreeQ[_TerminatedEvaluation]]];
	vertices = If[Length[path] > 0, MapIndexed[#2[[1]] -> #1 &, path[[2 ;; ;; 2]]], {}];
	edges  = Map[DirectedEdge[#[[2]], #[[4]], #[[1]] -> #[[3]]] &, Partition[Riffle[path[[;; ;; 2]], vertices], 4, 2]];
	Graph[
		vertices,
		edges,
		FilterRules[{opts}, Options[Graph]],
		VertexShapeFunction -> If[TrueQ[OptionValue["HighlightChanges"]],
			Append[Last[vertices] -> vsf] @ MapThread[{v, pos} |-> v -> Function[vsf[#1, ReplaceAt[#2, x_ :> RuleCondition[Style[HoldForm[x], highlightOpts]], Join[{2, 1}, pos]], #3]], {Most[vertices], edges[[All, 3, 2]]}],
			vsf
		],
		(*EdgeLabels -> DirectedEdge[_, _, _ -> to_] :> to,*)
		EdgeStyle -> ResourceFunction["WolframPhysicsProjectStyleData"]["StatesGraph","EdgeStyle"],
		FormatType -> StandardForm,
		GraphLayout -> "SpiralEmbedding",
		PerformanceGoal -> "Quality"
	]
]
]

Options[TracePathGraph] = Join[Options[TracePath], Options[tracePathGraph]];

TracePathGraph[expr_, patt_, opts : OptionsPattern[]] := tracePathGraph[TracePath[expr, patt, FilterRules[{opts}, Options[TracePath]]], FilterRules[{opts}, Options[tracePathGraph]]]

Options[traceCausalGraph] = Join[{
	"IncludeInitialEvent" -> False, "ShowEventOrder" -> False
},
	Options[eventVertexShapeFunction], Options[stateVertexShapeFunction], Options[TracePathGraph]
];

Options[TraceCausalGraph] = Options[traceCausalGraph];

TraceCausalGraph[expr_, n : _Integer | Infinity : Infinity, patt_ : _, "PathCausalGraph" | "EvolutionCausalGraph", opts : OptionsPattern[]] := With[{
	vsf = stateVertexShapeFunction[FilterRules[{opts}, Options[stateVertexShapeFunction]]],
	highlightOpts = {OptionValue["HighlightOptions"], OptionValue[Options[tracePathGraph], "HighlightOptions"]}
},
Block[{
	cg = TraceCausalGraph[expr, n, patt, "CausalGraph", FilterRules[{opts}, Except[Options[Graph], Options[TraceCausalGraph]]]], events, stateVertices
},
	events = VertexList[cg];
	stateVertices = First[Reap[cg = EdgeAdd[cg, Catenate[{If[#[[1, 1]] == 0, Nothing, Sow[#[[1]]] -> #], # -> #[[2]]} & /@ VertexList[cg]]]][[2]], {}];
	Graph[
		cg,
		FilterRules[{opts}, Options[Graph]],
		VertexShapeFunction -> If[TrueQ[OptionValue["HighlightChanges"]],
			Prepend[_Rule -> vsf] @ MapThread[{v, pos} |-> v -> Function[vsf[#1, ReplaceAt[#2, x_ :> RuleCondition[Style[HoldForm[x], highlightOpts]], Join[{2, 1}, pos]], #3]], {stateVertices, events[[All, 3, 2]]}],
			_Rule -> vsf
		],
		VertexStyle -> Except[_DirectedEdge] -> ResourceFunction["WolframPhysicsProjectStyleData"]["StatesGraph", "VertexStyle"],
		EdgeStyle -> Except[DirectedEdge[_DirectedEdge, _DirectedEdge]] -> ResourceFunction["WolframPhysicsProjectStyleData"]["StatesGraph","EdgeStyle"]
	]
]
]

TraceCausalGraph[expr_, n : _Integer | Infinity : Infinity, patt_ : _, "PathEventsGraph" | "EvolutionEventsGraph", opts : OptionsPattern[]] :=
	Graph[EdgeDelete[TraceCausalGraph[expr, n, patt, "PathCausalGraph", FilterRules[{opts}, Except[Options[Graph], Options[TraceCausalGraph]]]], DirectedEdge[_DirectedEdge, _DirectedEdge]], FilterRules[{opts}, Options[Graph]], GraphLayout -> "SpiralEmbedding"]

TraceCausalGraph[expr_, n : _Integer | Infinity : Infinity, patt_ : _, "EvolutionEventsGraph", opts : OptionsPattern[]] :=
	EdgeDelete[TraceCausalGraph[expr, n, patt, "PathGraph", FilterRules[{opts}, Except[Options[Graph], Options[TraceCausalGraph]]]], DirectedEdge[_DirectedEdge, _DirectedEdge], FilterRules[{opts}, Options[Graph]], GraphLayout -> "SpiralEmbedding"]

holdRow = If[Length[#] != 1, Replace[#, _[xs___] :> HoldForm[Row[{xs}, ","]]], HoldForm @@ #] &;

TraceCausalGraph[expr_, n : _Integer | Infinity, patt_, "Path", opts : OptionsPattern[]] :=
	TracePath[expr, patt, FilterRules[{opts}, Options[TracePath]], "TraceSteps" -> n]

TraceCausalGraph[expr_, n : _Integer | Infinity, patt_, prop : "Graph" | "PathGraph" | "CausalGraph", opts : OptionsPattern[]] :=
	traceCausalGraph[TracePathGraph[expr, patt, FilterRules[{opts}, Options[TracePathGraph]], "TraceSteps" -> n], prop, FilterRules[{opts}, Options[traceCausalGraph]]]

traceCausalGraph[initPathGraph_, prop : "Graph" | "PathGraph" | "CausalGraph", opts : OptionsPattern[]] := Block[{
	pathGraph = initPathGraph, events, cg, embedding
},
	If[TrueQ[OptionValue["IncludeInitialEvent"]] && VertexCount[pathGraph] > 0, pathGraph = EdgeAdd[pathGraph, DirectedEdge[0 -> HoldComplete[Missing[]], #, {-1} -> {}] & @ First[VertexList[pathGraph]]]];
	If[MatchQ[prop, "Graph" | "PathGraph"], Return[pathGraph]];
	events = EdgeList[pathGraph];
	If[TrueQ[OptionValue["IncludeInitialEvent"]], events = RotateRight[events]];

	If[ Length[events] > 0,
		cg = TransitiveClosureGraph @ Graph[events, DirectedEdge @@@ Partition[events, 2, 1]];
		cg = TransitiveReductionGraph @ EdgeDelete[cg,
			DirectedEdge[event1 : DirectedEdge[_, _, _ -> toLoc1_], event2 : DirectedEdge[_, _, _ -> toLoc2_]] /; ! positionDependQ[toLoc1, toLoc2]
		]
		,
		cg = Graph[events, {}]
	];
	cg = Graph[cg,
		FilterRules[{opts}, Options[Graph]],
		VertexShapeFunction -> eventVertexShapeFunction[FilterRules[{opts}, Options[eventVertexShapeFunction]]],
		VertexLabels -> DirectedEdge[_ -> f_, _ -> t_, _ -> p_] :> Placed[Style[DirectedEdge[HoldForm @@ f, HoldForm @@ t, p], 12], Tooltip],
		VertexStyle -> {
			_DirectedEdge -> ResourceFunction["WolframPhysicsProjectStyleData"]["CausalGraph", "VertexStyle"],
			Except[_DirectedEdge] -> ResourceFunction["WolframPhysicsProjectStyleData"]["StatesGraph", "VertexStyle"]
		},
		EdgeStyle -> {
			DirectedEdge[_DirectedEdge, _DirectedEdge] -> ResourceFunction["WolframPhysicsProjectStyleData"]["CausalGraph","EdgeStyle"],
			Except[DirectedEdge[_DirectedEdge, _DirectedEdge]] -> ResourceFunction["WolframPhysicsProjectStyleData"]["StatesGraph","EdgeStyle"]
		},
		PerformanceGoal -> "Quality", FormatType -> StandardForm
	];
	Replace[OptionValue["ShowEventOrder"], x : Except[False | None] :> (cg = Graph[cg, Epilog -> {Replace[x, True | Automatic -> Directive[Arrowheads[{{Automatic, .5}}], Thick, Red]], Arrow /@ Partition[GraphEmbedding[cg], 2, 1]}])];
	
	cg
]

TraceCausalGraph[expr_, n : _Integer | Infinity : Infinity, patt_ : _, prop_String /; StringEndsQ[prop, "GraphStructure"], opts : OptionsPattern[]] :=
	TraceCausalGraph[expr, n, patt, StringDelete[prop, "Structure"], VertexShapeFunction -> Automatic, opts]

TraceCausalGraph::missingProp = "Missing property: ``";
TraceCausalGraph[_, _Integer | Infinity, _, prop_String, OptionsPattern[]] /; Message[TraceCausalGraph::missingProp, prop] := $Failed

(* missing pattern *)
TraceCausalGraph[expr_, n : _Integer | Infinity, prop_String : "CausalGraph", opts : OptionsPattern[]] :=
	TraceCausalGraph[expr, n, _, prop, opts]

(* missing property *)
TraceCausalGraph[expr_, n : _Integer | Infinity, patt_, opts : OptionsPattern[]] :=
	TraceCausalGraph[expr, n, patt, "CausalGraph", opts]

(* missing steps and pattern *)
TraceCausalGraph[expr_, prop_String : "CausalGraph", opts : OptionsPattern[]] := TraceCausalGraph[expr, Infinity, _, prop, opts]

(* missing steps *)
TraceCausalGraph[expr_, patt_, prop_String : "CausalGraph", opts : OptionsPattern[]] := TraceCausalGraph[expr, Infinity, patt, prop, opts]

Documentation

UsageResourceCreateNotebook

Details & OptionsResourceCreateNotebook

Tracing functions with Flat, Orderless, OneIdentity attributes and other things that lead to non-standard evaluation (like Sequence) is not properly supported.

TraceCausalGraph takes the following options:

({{"IncludeInitialEvent", False, whether to include an additional event that produces original expression}, {"ShowIndices", False, show event indices}, {"ShowEventOrder", False, show evaluation order with a path between events}, {"ShowPositions", False, show event position with negative position indicating internal evaluations}, {"ShowExpressions", True, show complete or partial expressions}, {"PruneIdentities", True, prune events that evaluate expression to itself}, {"PruneSidePaths", False, prune expressions that do not correspond to any part of original expression}, {"PruneTerminatedEvaluation", True, prune expression with TerminatedEvaluation}, {"EventStyleOptions",  , Style options for an event}, {"EventColumnOptions",  , Column options for before/after part of an event}, {"EventFrameOptions",  , Framed options for an event}, {"SideEventFrameOptions",  , Framed options for side events}, {“StateStyleOptions”,  , Style options for a state}, {“StateFrameOptions”,  , Framed options for a state}})

ExamplesResourceCreateNotebook

Basic Examples

Make a causal graph from a standard evaluation of an expression:

TraceCausalGraph[(1+(2+3))+(4×5)]

Make a path consisting of intermediate expressions together with subexpression positions being evaluated:

TraceCausalGraph[(1+(2+3))+(4×5),"Path"]

Make a path graph of expressions in a trace:

TraceCausalGraph[(1+(2+3))+(4×5),"PathGraph"]

Make a path with interspersed events between expressions:

TraceCausalGraph[(1+(2+3))+(4×5),"PathEventsGraph"]

Add dependency edges between events:

TraceCausalGraph[(1+(2+3))+(4×5),"PathCausalGraph"]

Scope

Trace a more complicated expression:

ClearAll[fib]
fib[n_]:=fib[n-1]+fib[n-2]
fib[0|1]=1;

TraceCausalGraph[fib[3]]

Tracing internal functions would result in side-events (indicated by a dashed boundary):

TraceCausalGraph[FoldList[Plus,0,{1,2,3}]]

TraceCausalGraph[Table[i^2+i,{i,2}],GraphLayout->{"LayeredDigraphEmbedding","Orientation"->Left}]

Options

IncludeInitialEvent

Include an additional event that all events causally depend on:

TraceCausalGraph[2*3+4*5+6*7,"IncludeInitialEvent"->True]

ShowIndices

Show indices of events in evaluation order:

TraceCausalGraph[1+(2+(3+4)),"ShowIndices"->True]

ShowEventOrder

Indicate an actual order of events during evaluation:

TraceCausalGraph[(1+2)+(((3+4))^5),"ShowEventOrder"->True]

ShowPositions

Show positions of subexpression being evaluated:

TraceCausalGraph[1+(2+(3+4)),"ShowPositions"->True]

With side-events having decreasing negative part numbers:

TraceCausalGraph[Nest[f,1,3],"ShowPositions"->True]

ShowExpressions

Instead of the whole expression show only subexpressions under evaluation:

TraceCausalGraph[1+(2+(3+4)),"ShowExpressions"->False]

PruneIdentities

Trivial identity events are pruned by default:

TraceCausalGraph[1+(2+3),"PruneIdentities"->False]

PruneSidePaths

Prune side-paths from a trace PathGraph and corresponding events:

f[n_/;n>1]:=f[n-1]

TraceCausalGraph[f[3],"PruneSidePaths"->False]

TraceCausalGraph[f[3],"PathGraph","PruneSidePaths"->True]

TraceCausalGraph[f[3],"PruneSidePaths"->True]

PruneTerminatedEvaluation

Terminating after non-terminal amount of steps results in TerminatedEvaluation inside of the last event:

GraphicsRow[Table[TraceCausalGraph[(1+2)^3,n,"PruneTerminatedEvaluation"->False,PlotLabel->Row[{n,If[n==1,"step","steps"]}," "],GraphLayout->"SpiralEmbedding"],{n,4,12,2}],Frame->All]

Applications

Properties and Relations

Possible Issues

Non-standard evaluation, like flattening of Flat subexpressions results in incorrect reconstruction of intermediate expressions:

ClearAll[f]
SetAttributes[f,Flat]
f[x,a]:=f[a,x]
TraceCausalGraph[f[x,a,a],"PathGraph"]

Neat Examples

Trace a Fibonacci function with memoization:

ClearAll[f]
f[0]=f[1]=1; f[n_]:=f[n]=f[n-1]+f[n-2]

TraceCausalGraph[f[8],"CausalGraphStructure",GraphLayout->"LayeredDigraphEmbedding"]

Make a causal graph of a nested recursive function:

Clear[f]
f[n_]:=f[n-f[n-3]]+f[n-2]
f[n_/;n<1]=1;

TraceCausalGraph[f[5],"CausalGraphStructure"]

TraceCausalGraph[f[5],"CausalGraphStructure",GraphLayout->"LayeredDigraphEmbedding",AspectRatio->2]

Divide-and-conquer factorial:

f[l_List]:=Times@@f/@TakeDrop[l,Quotient[Length[l],2]]
f[{x_}]:=x

TraceCausalGraph[f[Range[10]],"CausalGraphStructure"]

Trace itself:

TraceCausalGraph[TraceCausalGraph[(1+(2+3))+(4×5)],6,"PathCausalGraph"]

Source & Additional Information

Contributed ByResourceCreateNotebook

Nik Murzin

KeywordsResourceCreateNotebook

trace

path

graph

event

causal dependency

Categories

Related SymbolsResourceCreateNotebook

Trace

Graph

PathGraph

Related Resource ObjectsResourceCreateNotebook

TraceGraph

TraceTree

TraceView

SubstitutionSystemCausalGraph

MultiwaySystem

Wolfram/Multicomputation

Source/Reference CitationResourceCreateNotebook

Source, reference or citation information

LinksResourceCreateNotebook

Link to other related material

TestsResourceCreateNotebook

MyFunction[x,y]

CompatibilityResourceCreateNotebook

Wolfram Language VersionResourceCreateNotebook

13.0+

Operating SystemResourceCreateNotebook

Required FeaturesResourceCreateNotebook

EnvironmentsResourceCreateNotebook

Cloud SupportResourceCreateNotebook

Author NotesResourceCreateNotebook

Additional information about limitations, issues, etc.

Submission NotesResourceCreateNotebook

Additional information for the reviewer.