(*:Version: Mathematica 2.0 - 2.2 *)
(*:Name: InheritRules` *)
(*:Title: InheritRules *)
(*:Author: Jason F. Harris *)
(* Date: 28 June 1994 *)
(*:Keywords: Inheritance, Rule, UpValues, DownValues, Object Oriented, Hierarchy *)
(*:Requirements: none *)
(*:Warnings: none. *)
(*:To Do:
Print a warning when rules are being deleted or UpValues and DownValues
are being shuffled. See Implementation Notes Num 6.(below) *)
(* Should change the error checking to return failed. at the end. *)
(*:Source: none. *)
(*:Limitations: none. *)
(*:Discussion:
InheritRules is a package that will create new rules for a child symbol from the
prescribed rules of parent symbols. So the child inherits the rules of the parents.
This inheritance paradigm is similar to Object Oriented Programming but is
more general. It does not rely on the instantiation and message passing nature
of OOP.
Basically this package just inherits rule sets from one symbol to another. It
is simple and elegent and general, but in being so it sometimes leaves alot to
the user. I.E. this is not AXIOM. It might be the low level drivers for a
mathemeatica package to implement AXIOM, but I have yet to write this.
*)
(*:Examples:
# define some rules #
In[1]:=
f/: f[x_]+g[y_]:=h[x,y]
f/: f[t_,r]:=h[t]
# then inherit them by #
In[2]:=
InheritRules[w,{f}]
In[3]:=
?w
Out[3]=
w/: w[x_] + g[y_] := h[x, y]
w[t_, r] := h[t]
# inherit from both parents with substitutions #
In[4]:=
InheritRules[u,{f,h->ans},{w,t->x,r->l}]
In[5]:=
?u
Out[5]=
u/: u[x_] + g[y_] := ans[x, y]
u[t_, r] := ans[t]
u[x_, l] := h[x]
See the file "Inherit Rule Examples" for further examples.
*)
(* :Implementation Notes:
The package is simple and basically implements
UpValues[child] = UpValues[parent]//.{parent->child,replacememnts}
DownValues[child] = DownValues[parent]//.{parent->child,replacememnts}
The main body is just this except for the additions below
1. Since we can inherit off multiple parents in the one call
we deifine the intermediate variables
newDownRules (and newUpRules)
This is just the list
Join[DownValues[parent1]//.{parent1->child,replacememnts1},
DownValues[parent2]//.{parent2->child,replacememnts2},
...]
(and similarly for the up values). The newDownRules and
newUpRules are computed in computeNewValues.
2. The boolean option OldRulesFirst dictates wether the
new rules override the old or the old override the new
if there is any overlap. The default is True
3. The boolean option StrictInheritance if True will make inheritance behave like
Rules[child] = Rules[parent]//.{parent->child,replacememnts}
If False Inheritance will behave like
Rules[child] = Rules[parent]//.{replacememnts}
The default is True.
4. The boolean option Verbose if True will make InheritRules print some
diagnostics when inheritance takes place. The Default is False.
5. cleanRules just cleans up the rules getting
rid of overriden Rules.
6. We can somtimes generate nonsense rules through inheritance.
For instance consider f from above
In[]=
InheritRules[g,{f,f->p},StrictInheritance->False]
Then we have generated the rules
g/: p[x_]+g[y_]:=h[x,y]
g/: p[t_,r]:=h[t]
And of course only the first rule makes sense. Even though the
prescence of this second rule does nothing, we remove it anyway.
Also even more complex is apart from the rules that are no longer
vaild, some UpValues might become DownValues, and vice-versa. So we
test the UpValues(DownValues) to see if they can still be
UpValues(DownValues), if not we see if they can be DownValues(UpValues).
If they can't be that either than we delete them.
For a fuller example see the file Inherit Rule Examples: an untyped group
7. Fairly Full error checking is implemented.
*)
BeginPackage["InheritRules`"];
Unprotect[InheritRules];
ClearAll[InheritRules];
InheritRules::usage =
"InheritRules[child,{parent},opts] will create inherited rules for
child prescribed by the rules of the parent as in\n
Rules[child] = Rules[parent] //. {parent->child}\n\n
InheritRules[child,{parent1,replacements1},...,{parenti,replacementsi},opts]
will create inherited rules for child prescribed by the rules of the parents
and their replacements as in \n
Rules[child] = Join[ Rules[parent1] //. {parent1->child,replacements1},...,\n
Rules[parenti] //. {parenti->child,replacementsi}]";
OldRulesFirst::usage =
"OldRulesFirst is a boolean option for InheritRules. If
this option is true than any existing rules for child will
not be overriden by conflicting rules from the parents. If
this option is False then the parents rules will always take
precedence over the childs rules. Default is True.";
StrictInheritance::usage =
"StrictInheritance is a boolean option for InheritRules. The default
value of this option is True, which forces inheritance to behave like\n
Rules[child] = Rules[parent]//.{parent->child,replacememnts}\n\n
If this option is False then Inheritance will behave like\n
Rules[child] = Rules[parent]//.{replacememnts}";
Verbose::usage =
"Verbose is a boolean option for InheritRules. If this option is
True InheritRules will print some diagnostic information while
inheritance takes place. The Default is False.";
Options[InheritRules] =
{OldRulesFirst -> True,StrictInheritance->True,Verbose->False};
InheritRules::badChild="The child `1` must be a symbol in `2`.";
InheritRules::badParentReplacement=
"`1` are not of the form {parent,replacements} in `2`.";
InheritRules::badParent="The parent `1` must be a symbol in `2`.";
InheritRules::badReplacements=
"`1` is not a vaild replacement rule for the parent `2` in `3`.";
InheritRules::badOpts="`1` are not valid options in `2`.";
InheritRules::noParents="no parents have been given in `1`.";
Begin["`Private`"];
(*-----*)
(* predicate testing functions & Simple functions. *)
ruleQ[a_]:= (Head[a]==Rule || Head[a]==RuleDelayed)
notRuleQ[a_] := ! ruleQ[a]
notSymbolQ[a_]:= Head[a]=!=Symbol
notListQ[a_] := Head[a]=!=List
notListOrOptionQ[a_] := Head[a]=!=List && Not[OptionQ[a]]
validParentReplacementQ[{parent_Symbol,replacements___?ruleQ}]:=True
validParentReplacementQ[___]:=False
unSortedComplement[{a___,b_,c___},{d___,b_,e___}]:=unSortedComplement[{a,c},{d,e}]
unSortedComplement[a_,b_]:=Join[a,b]
(*--------------------------------------------------------------*)
(* compute the set of rules to add to the DownValues or UpValues, *)
(* depending on upOrDown and the boolean option optStrictInheritance.*)
computeNewValues[upOrDown_,optStrictInheritance_,child_,{parent_,replacements___}]:=
If[optStrictInheritance,
upOrDown[parent]//.{parent->child,replacements},
upOrDown[parent]//.{replacements}]
(*--------------------------------------------------------------*)
InheritRules[child_Symbol,parentAndReplacements:{_Symbol,___?ruleQ}..,opts___?OptionQ]:=
Block[{optOldRulesFirst,optStrictInheritance,optVerbose,newDownRules,newUpRules},
optOldRulesFirst = OldRulesFirst /. {opts} /. Options[InheritRules];
optStrictInheritance = StrictInheritance /. {opts} /. Options[InheritRules];
optVerbose = Verbose /. {opts} /. Options[InheritRules];
(* Compute the inherited Rules *)
newDownRules = Flatten[computeNewValues[DownValues,optStrictInheritance,child,#] & /@
{parentAndReplacements},1];
newUpRules = Flatten[computeNewValues[UpValues,optStrictInheritance,child,#] & /@
{parentAndReplacements},1];
(* Combine the inherited rules with the old rules of the child.*)
If[optOldRulesFirst,
(* old rules first *)
(newDownRules = cleanRules[Join[DownValues[child],newDownRules],child];
newUpRules = cleanRules[Join[UpValues[child],newUpRules],child]),
(* new rules first *)
(newDownRules = cleanRules[Join[newDownRules,DownValues[child]],child];
newUpRules = cleanRules[Join[newUpRules,UpValues[child]],child])
]; (* End if*)
(* upNowDown are the UpValues that should now be DownValues. *)
(* downNowUp are the DownValues that should now be UpValues. *)
(* Note we have already removed the rules that cannot be *)
(* assigned as UpValues or a DownValues. *)
upNowDown=Select[newUpRules,(! possibleUpQ[#[[1]],child])&];
downNowUp=Select[newDownRules,(! possibleDownQ[#[[1]],child])&];
(* Then assign the corrected sets of rules to the UpValues *)
(* and DownValues. *)
UpValues[child] = Join[unSortedComplement[newUpRules,upNowDown],downNowUp];
DownValues[child] = Join[unSortedComplement[newDownRules,downNowUp],upNowDown];
If[optVerbose,(
Print["UpValues that should be DownValues = ",upNowDown];
Print["DownValues that should be UpValues = ",downNowUp];
Print["Final assigned UpValues = ",UpValues[child]];
Print["Final assigned DownValues = ",DownValues[child]];
)];(* end verbose*)
];
(*--------------------------------------------------------------*)
(* These test to see if the Rule expr_Literal:>b_ can be *)
(* associated with the child symb as an DownValue or as a an *)
(* UpValue respectivley. *)
possibleDownQ[expr_Literal,symb_Symbol] := Count[expr,(symb|symb[___]),{1}]>0
possibleUpQ[expr_Literal, symb_Symbol] :=
Count[expr,
(symb | symb[___] |
(b:Blank | BlankSequence| BlankNullSequence)[symb] |
(p:Pattern)[_,(b:Blank | BlankSequence| BlankNullSequence)[symb]]), {2}]>0
(* This removes multiple occurances of rules that have the same *)
(* left hand side as previous ones. Also If through inheritance *)
(* the rule has become meaningless (i.e. the child cannot be *)
(* assigned this rule either as a DownValue or an UpValue then *)
(* delete it. *)
cleanRules[{a___,b_:>c_,d___,b_:>_,f___},child_] := cleanRules[{a,b:>c,d,f},child];
cleanRules[{a___,b_Literal:>_,c___},child_]/;
(Not[possibleDownQ[b,child]] && Not[possibleUpQ[b,child]]):= cleanRules[{a,c},child];
cleanRules[a___,child_]:=a;
(*--------------------------------------------------------------*)
(* If we get here we must have an incorrect calling *)
(* find out which one and give the apropriate error messgae *)
p:Literal[InheritRules[a_?notSymbolQ,___]]:=
returnError/;Message[InheritRules::badChild,a,HoldForm[p]];
p:Literal[InheritRules[a_Symbol,___List,{parent_?notSymbolQ,___},___List,___?OptionQ]]:=
returnError/;Message[InheritRules::badParent,parent,HoldForm[p]];
p:Literal[InheritRules[a_Symbol,___List,
{parent_Symbol,___,replacements_?notRuleQ,___},___List,___?OptionQ]]:=
returnError/;Message[InheritRules::badReplacements,replacements,parent,HoldForm[p]];
p:Literal[InheritRules[a_Symbol,parentPairs___,___?OptionQ]]:=
returnError/;
Message[InheritRules::badParentReplacement,
Select[{parentPairs}, ! validParentReplacementQ[#]& ],
HoldForm[p]];
p:Literal[InheritRules[a_Symbol,___?OptionQ]]:=
returnError/;Message[InheritRules::noParents,HoldForm[p]];
(*--------------------------------------------------------------*)
End[]; (* Private *)
Protect[InheritRules];
EndPackage[];