lshifr
12/22/2015 - 9:09 AM

An implementation of a function constructor that takes (possibly overloaded) function definitions using standard pattern-based syntax (where

An implementation of a function constructor that takes (possibly overloaded) function definitions using standard pattern-based syntax (where function name should be denoted as Fn), and returns a Function-based definition that is garbage-collectable

BeginPackage["RuleBasedFunction`"]

RuleBasedFunction::usage = "RuleBasedFunction[defs, attrs] constructs a pure function based on definitions given by rules";

Fn::usage = "Fn is a symbol used to denote a function in definitions used in RuleBasedFunction";

Begin["`Private`"]

SetAttributes[CleanUp, HoldAll]
CleanUp[expr_, cleanup_] :=
  Module[{exprFn, result, abort = False, rethrow = True, seq}, 
    exprFn[] := expr;
    result = 
      CheckAbort[
         Catch[Catch[result = exprFn[]; rethrow = False; result], _, 
           seq[##] &], abort = True];
    cleanup;
    If[abort, Abort[]];
    If[rethrow, Throw[result /. seq -> Sequence]];
    result]

Unprotect[RuleBasedFunction, Fn];
ClearAll[RuleBasedFunction, Fn];
SetAttributes[Fn, Protected];

SetAttributes[RuleBasedFunction, HoldFirst];
Options[RuleBasedFunction] = {Evaluator -> Normal};
RuleBasedFunction[defs:{(_Set|_SetDelayed)..}, attrs_List:{}, opts:OptionsPattern[]]:=
	Module[{temp},
		Unevaluated[defs] /. Fn -> temp;
		With[{result = iRuleBasedFunction[temp, attrs, OptionValue[Evaluator]]},
			Remove[temp];
			result
		]
	];


(* This version constructs and then removes a temporary symbol with all function's
definition at every call. It fully follows the Mathematica's evaluation semantics,
but the symbol copy-remove procedure induces some overhead *)
ClearAll[iRuleBasedFunction];
SetAttributes[iRuleBasedFunction, HoldFirst];
iRuleBasedFunction[sym_Symbol, atts_List, Normal]:=
	With[{dv = DownValues[sym] /. HoldPattern[sym] :> Fn},
		Function[
			Null
			, 
			Module[{tmp, result},
				DownValues[tmp] = dv /. Fn -> tmp;
				SetAttributes[tmp, atts];
				CleanUp[
					result = tmp[##]
					,
					result = result /. tmp -> #0;
					Remove[tmp];
				];
				result
			]
			,		 
			atts
		]
	];

(* This option does not replicate the full evaluation semantics of Mathematica, 
but can be much faster. In most cases, this is a good choice. It is not a default
however, since it won't be correct in certain cases *)
iRuleBasedFunction[sym_Symbol, atts_List, ReplaceRepeated]:=
	Module[{fn},
		SetAttributes[fn, atts];
		With[{rules = DownValues[sym] /. HoldPattern[sym] :> fn},
			Function[Null, fn[##] //. rules, atts]
		]
	];
		
End[]

EndPackage[]