(*:Version: 1.0 Mathematica 2.0 - 2.2 *)
(*:Name: Semantica` *)
(*:Title: Semantica *)
(*:Author: Jason F. Harris *)
(*:Date: 13 September 1995 *)
(*:Keywords: Pattern Matching, Semantics, Semantic Pattern Matching,
Algebraic, MatchQ, Matchings *)
(*:Requirements: None *)
(*:Warnings:
Overrides Replace, ReplaceRepeated, ReplaceAll, Dispatch, Set, SetDelayed.
Although it does this in a nice way that should not interfere with
anything except semantic patterns, semantic transformation rules and
semantic assignments. *)
(*:To Do:
Possibly give more warnings, in dangerous situations.
For instance a non-linear pattern appearing inside a Semantic
wrapper and outside of one should be handled.
We could possibly auto-distribute Alternatives inside a Semantic, but
I have left this for a possible future version.
Possibly put in an option for Semantica for the expand function used
to verify returned solutions are actually solutions to the equations.
Something like: CompareFunctionInVerify -> TrigReduce, etc.
Maybe an option for selection of a single solution among multiple solutions.
However this can presently just be specified as a condition in the original,
semantic assignment.
*)
(*:Source: Semantic Patterns in Mathematica Article. *)
(*:Limitations:
Finer control could be gained by using a different Solve,
but if one really wanted this they should probably just
reformulate their patterns. *)
(*:Discussion:
The main article introduces semantic patterns, discusses them,
and examines current mechanisms for "Semanticness".
For a good background read the article, however very very briefly:
A semantic pattern is one that matches according to mathematical
equivalence, not just syntactic equivalence. For instance
f[2 n_] will not match f[8] since 8 is not of the form Times[2,...]
but this is "mathematically" possible to match, i.e. n = 4 would
obviously satisfy this. To accomplish this matching, Semantica
enables Mathematica to use "semantic patterns".
For instance:
f[Semantic[ 2 n_]] will match f[8] with the binding n -> 4.
We can make definitions and transformation rules involving semantic
patterns and conditions on them e.g.
f[Semantic[ 2 n_]] := n^2 /; n < 7.
Semantica works by transmuting/transforming/compiling/ any
semantic rule or semantic assignment into an equivalent
syntactical rule or assignment. It uses the Solve command inside
this new syntactical rule or assignment to process the "semantic"
matchings.
For more motivation, examples and explanations see the article.
*)
(*:Code Description:
The code is documented in the article Semantic Pattern Matching in
Mathematica. Unfortunately the article cannot go
into all the depth required to completely explain the workings
of this package.
The ideas behind the code are quite simple; however some of the
details are a bit obtuse.
Semantica works by using a customized mix of Solve and SolveAlways.
It uses a lot of pattern matching and manipulating patterns
themselves. Also notable is that the main SemanticToSyntactic
function uses dynamic scoping to scope all the variables that
contain the pattern parts, as the semantic pattern gets surgically
destroyed and the syntactic pattern gets surgically built.
*)
(*##############################################################*)
(*######### S E M A N T I C A ################*)
(*##############################################################*)
BeginPackage [ "Semantica`","Utilities`Notation`" ];
SemanticToSyntactic::usage =
"SemanticToSyntactic[rule] will transmute a transformation rule
containing semantic patterns, into an equivalent syntactical
rule. It is not usually directly called instead it is transparently
and automatically called when appropriate by
Replace, ReplaceRepeated, ReplaceAll, Dispatch, Set and SetDelayed.";
Semantic::usage =
"Semantic[patt] is a semantic pattern. Semantic acts only as a
wrapper. The only pattern matching mechanisms that can be present in
patt are single blanks (possibly restricted to given heads),
PatternTests, Conditions and names i.e. Pattern constructs.";
SolveWithConditions::usage =
"SolveWithConditions[eqns, solveVars, solveAlwaysVars, conds] will
attempt to solve an equation or set of equations for the variables
vars that is valid for all values of the variables solveAlwaysVars
and subject to the conditions conds. It is a mixture of Solve,
SolveAlways and Select.";
CleanUpSolutions::usage =
"CleanUpSolutions[{solutions}] will pick a single solution or return
a multiple solution object depending on MultipleSolutionsOpt.";
MultipleSolutions::usage =
"MultipleSolutions is returned by a semantic reduction when there
is more than one possible solution. MultipleSolutions objects distribute
themselves over the arithmetic operators.";
MultipleSolutionsOpt::usage =
"MultipleSolutionsOpt is a background boolean option for Semantica.
If True then MultipleSolutions objects will be returned if necessary from
SolveWithConditions. If False then the shortest solution is returned.
If Optimizing is on this option is ignored.";
Optimizing::usage =
"Optimizing is a boolean option for Semantica. If True then
generic solutions will be generated by Reduce and these will be used to
create the syntactic definitions. If False then Solve will be called
each time the definition is called. True is faster, False is semantically
safer and sometimes gives simpler results, it is also needed when a semantic
pattern has structural symbols present in it.";
DeclareStructural::usage =
"DeclareStructural[symb] declares symb to be treated structurally when
used inside a semantic pattern.";
DeclareSemantic::usage =
"DeclareSemantic[symb] declares symb to be treated semantically when
used inside a semantic pattern.";
$CollectingSolutions::usage =
"$CollectingSolutions is a dummy symbol used in the construction of
definitions by Semantica. It indicates that the conditional expression is
used to collect a solution.";
$ClearSolutionList::usage =
"$ClearSolutionList is a dummy symbol used in the construction of
definitions by Semantica. It indicates that the conditional expression is
used to clear the solution list.";
(*--------------------------------------------------------------*)
Semantic::badPatterns =
"Semantic patterns can only contain single blanks (possibly restricted to
given heads), PatternTests, Conditions and names i.e. Pattern constructs.";
Semantic::nestedSemantics =
"Warning:: nested Semantic wrappers have been flattened since they are superfluous.";
Semantic::splitSemantics =
"Warning:: Semantic sequence has been split into a sequence of Semantics.";
Semantic::patternWarnings =
"OutOfDate: Changing.
patternWarnings is a background option for Semantic. If True then warnings
are printed when nested Semantics and sequences of Semantics are
transformed. If False then no warnings will be given.";
Semantica::multipleSolutions =
"Warning:: There was more than one solution to the semantic pattern.
Choosing symbolically shortest solution.";
Semantica::dangerousSolutions =
"Warning:: PowerExpand was needed to verify that the solutions
satisfied the original equations.";
Semantica::noSolution =
"Warning:: there were no variables to be solved for in the semantic patterns.
Solutions may be meaningless";
(*--------------------------------------------------------------*)
Options @ Semantica =
{SolutionWarnings -> True,
Verbose -> False,
MultipleSolutionsOpt -> True,
Optimizing -> True};
Begin @ "`Private`";
(*--------------------------------------------------------------*)
(* Define the Notations used in Semantica. *)
(* Need to do this because the package format is ugly and only *)
(* InputForm things are allowed. See the Notation documentation *)
(* On how to do this for your own packages. *)
(* Needs @ "Utilities`Notation`"; *)
Notation[NotationBoxTag[
SubscriptBox[RowBox[{"(","s_",")"}],"\[DoubleStruckCapitalS]"]]
\[DoubleLongLeftRightArrow]NotationBoxTag[
RowBox[{"Semantic","[","s_","]"}]]]
Notation[NotationBoxTag[
SubscriptBox[RowBox[{"{","s__","}"}],"\[DoubleStruckCapitalM]"]]
\[DoubleLongLeftRightArrow]NotationBoxTag[
RowBox[{"MultipleSolutions","[","s__","]"}]]]
(*--------------------------------------------------------------*)
(* The pure function returned by containsQ must have the *)
(* attribute HoldAll or else evaluation of its argument could *)
(* take place. *)
containsQ @ patt_ :=
Function[expr, Not @ FreeQ[Unevaluated @ expr, Unevaluated @ patt], {HoldAll}]
freeOfQ @ patt_ :=
Function[expr, FreeQ[Unevaluated @ expr, Unevaluated @ patt], {HoldAll}]
notOptionQ @ a___ := Not @ OptionQ @ a
(*--------------------------------------------------------------*)
(* We use the wrapper hold (small h) quite extensively through *)
(* out this package. Since we need to insert many holding *)
(* functions that can later be withdrawn. We also must use a *)
(* different wrapper then Hold since the patterns the user *)
(* specify may contain a Hold in them. *)
ClearAll[hold, inertHold, fromInert, toInert];
SetAttributes[{hold,inertHold,toInert}, HoldAll];
flattenhold @ expr_ := hold @@ (Hold @ expr //. hold @ any___ -> any);
toInert @ expr_ :=
Unevaluated @ expr /.
symb_Symbol /; !StringMatchQ[ fullSymbolName @ symb, "inert`*"] :>
ToExpression["inert`"<> fullSymbolName @ symb];
fromInert @ expr_ :=
(expr /. symb_Symbol /; StringMatchQ[fullSymbolName @ symb, "inert`*"] :>
With[{oldSymb = inertHold @@ ToHeldExpression @ StringDrop[ToString @ symb, 6]},
oldSymb /; True]) //. inertHold @ a_ :> a;
(*--------------------------------------------------------------*)
(* fullSymbol returns the full name of the symbol including its *)
(* Context. *)
SetAttributes[fullSymbolName, HoldAll];
fullSymbolName @ symb_ :=
With[{theContext = Context @ Unevaluated @ symb,
theString = ToString @ Unevaluated @ symb},
If[ FreeQ[$ContextPath, theContext], theString, theContext <> theString]]
(*--------------------------------------------------------------*)
activateSystemSymbols @ symb_Symbol :=
If[ Context @ symb === "inert`System`", fromInert @ symb, symb];
activateSystemSymbols @ other_ := other;
(*--------------------------------------------------------------*)
(* This specifies whether any symbols appearing inside a *)
(* semantic wrapper that are not pattern variables should be *)
(* treated semantically or structurally. *)
DeclareStructural @ symb_Symbol := (structuralQ @ symb = True;);
DeclareStructural @ symbs__List := (DeclareStructural /@ symbs ;);
DeclareStructural [ symbs__ ] := (DeclareStructural /@ {symbs} ;);
DeclareSemantic @ symb_Symbol := (structuralQ @ symb = .;);
DeclareSemantic @ symbs__List := (DeclareSemantic /@ symbs ;);
DeclareSemantic [ symbs__ ] := (DeclareSemantic /@ {symbs} ;);
SetAttributes[structuralQ,HoldAll];
(*--------------------------------------------------------------*)
verbosePrint @ a_ /; verbosity :=
Print [ToString @ Unevaluated @ a, " = ", a];
SetAttributes [verbosePrint, HoldAll];
(*-----------------------------------------------------------*)
(* friendlyOff will turn off a message. friendlyOn will turn *)
(* that message on only if it was on before the friendlyOff. *)
SetAttributes[{friendlyOff, friendlyOn, wipe},HoldAll]
friendlyOff @ mesg_MessageName := (mesgWasOn @ Hold @ mesg = (Head @ mesg =!= $Off);
Off @ mesg;)
friendlyOn @ mesg_MessageName := If[mesgWasOn @ Hold @ mesg, On @ mesg]
(*##############################################################*)
(* Solve Equations With Conditions and Clean Them. *)
(*##############################################################*)
(* This finds all solutions of the equations eqns that have the *)
(* variables solveVars and whose solutions are free of *)
(* solveAlwaysVars and satisfy the conditions conds. *)
SetAttributes[SolveWithConditions, HoldAll];
SolveWithConditions[eqns_,solveVars_,{},conds_:True]:=
CleanUpSolutions @
(verifySolutions[#, eqns, conds] &) @
Solve[eqns, solveVars];
SolveWithConditions[eqns_,solveVars_,solveAlwaysVars_,conds_:True]:=
CleanUpSolutions @
(verifySolutions[#, eqns, conds] &) @
Solve[!Eliminate[!eqns, solveAlwaysVars],solveVars];
(*--------------------------------------------------------------*)
(* verifySolutions selects only solutions that satisfy the *)
(* equations. It is sometimes necessary to apply ExpandAll etc. *)
(* to determine whether a solution is in fact a valid solution. *)
SetAttributes[verifySolutions, HoldRest];
verifySolutions [{},___] = {};
verifySolutions [sols_List, eqns_, conds_]:=
Module[{filtered = Select[sols, ExpandAll[Unevaluated[eqns && conds] /. #]&]},
filtered /; filtered =!= {}]
verifySolutions [sols_List, eqns_, conds_]:=
Module[{dangerous = Select[sols, Simplify @ ExpandAll @ PowerExpand @ ExpandAll [
Unevaluated[eqns && conds] /. #]&]},
(Message[Semantica::dangerousSolutions];
dangerous) /; dangerous =!= {}]
verifySolutions [___] = {};
(*--------------------------------------------------------------*)
(* We have a data type MultipleSolutions to allow the returning *)
(* of multiple solutions. It is a flat structure that distributes*)
(* over arithmetic operations as well as a few others. *)
expr:MultipleSolutions[a___,b_MultipleSolutions,c___]:=Flatten[Unevaluated[expr],2,MultipleSolutions]
MultipleSolutions /: expr:f_?distributeOverQ[a___,MultipleSolutions @ b___,c___] :=
Distribute[Unevaluated @ expr,MultipleSolutions]
MultipleSolutions @ singleSolution_ := singleSolution
distributeOverQ @ symb_Symbol := distributeOverQ @ symb =
! FreeQ[Attributes @ symb, Listable];
distributeOverQ @ Replace = True;
distributeOverQ @ ReplaceAll = True;
distributeOverQ @ ReplaceRepeated = True;
distributeOverQ @ Apply = True;
(*--------------------------------------------------------------*)
(* This just cleans up the solutions returned by mixed solve *)
(* with conditions. It will return a single solution and warns *)
(* if there was more than one. The dominant solution in s *)
(* selection is the shortest one, if applicable. *)
CleanUpSolutions @ {} = {};
CleanUpSolutions @ {sol_} = sol;
CleanUpSolutions @ {sols___} :=
MultipleSolutions[sols] /; (MultipleSolutionsOpt /. Options @ Semantica);
CleanUpSolutions @ {sols___} := (Message[Semantica::multipleSolutions];
simplestExpression @ {sols})
(*--------------------------------------------------------------*)
(* simplestExpression just returns the shortest (in terms of the*)
(* number of symbols) expression in a list of expressions. *)
simplestExpression[exprs_List] :=
Sort[{simplifyCount[#], #} & /@ exprs][[1,2]]
simplifyCount[p_] :=
If[Head[p]===Symbol, 1,
If[IntegerQ[p],
If[p==0, 1, Floor[N[Log[2, Abs[p]]/3]]+If[p>0, 1, 2]],
If[Head[p]===Rational,
simplifyCount[Numerator[p]]+simplifyCount[Denominator[p]]+1,
If[Head[p]===Complex,
simplifyCount[Re[p]]+simplifyCount[Im[p]]+1,
If[NumberQ[p], 2,
simplifyCount[Head[p]]+If[Length[p]==0, 0,
Plus@@(simplifyCount/@(List@@p))]]]]]]
(*##############################################################*)
(* Dissect Semantic Patterns. *)
(*##############################################################*)
(*--------------------------------------------------------------*)
(* dissectSemanticPattern will transform a semantic pattern into*)
(* an equivalent set of equations. It uses the following *)
(* dynamically scoped variables : equations, solveVars, *)
(* solveAlwaysVars and conditionList. These are built up as the *)
(* pattern is transformed, rather than explicitly passing them *)
(* around in dissectSemanticPattern. *)
(* If the head of the expression is a Semantic wrapper then *)
(* generate a new dummy variable to substitute for the whole *)
(* expression. Then recursively dissect the expression building *)
(* up the equations that this dummy variable will satisfy. *)
dissectSemanticPattern @ inert`Semantica`Semantic @ spatt_ :=
With[{symb = Unique @ "\[Lambda]$"},
AppendTo[equations, symb == dissectSemanticPattern @ spatt];
symb_]
(* If the pattern is a simple named blank then add the pattern *)
(* variable to our variables that must be solved for. *)
dissectSemanticPattern @ inert`System`Pattern[symb_, inert`System`Blank[]] :=
(AppendTo[solveVars, symb];
symb)
(* If the pattern is a simple named blank restricted to a head, *)
(* then add the pattern variable to our variables that must be *)
(* solved for. Also add a condition to our condition list *)
(* forcing the pattern variable to have the given head. *)
dissectSemanticPattern @ inert`System`Pattern[symb_,aBlank_inert`System`Blank] :=
(AppendTo[solveVars, symb];
AppendTo[conditionList, inert`System`MatchQ[symb,aBlank] ];
symb)
(* If a symb names a more complicated expr, then treat symb as a*)
(* solve variable and add an equation symb == (what it names). *)
dissectSemanticPattern @ inert`System`Pattern[symb_,expr_] :=
(AppendTo[solveVars, symb];
AppendTo[equations, symb == dissectSemanticPattern @ expr];
symb)
(* If we have encounter a condition then add it to the condition*)
(* list and recursively handle the expression . *)
dissectSemanticPattern @ inert`System`Condition[expr_,cond_] :=
(AppendTo[conditionList, cond ];
dissectSemanticPattern @ expr)
(* If we have encounter a PatternTest then add it to the *)
(* condition list in the appropriate form. *)
dissectSemanticPattern @ inert`System`PatternTest[expr_,func_] :=
With[{recursed = dissectSemanticPattern @ expr},
AppendTo[conditionList, func @ recursed ];
recursed]
(* If the overall argument is non-atomic then distribute it *)
(* throughout the remaining expr. *)
dissectSemanticPattern @ h_ @ args___ :=
dissectSemanticPattern[h] @@ (dissectSemanticPattern /@ {args})
(* If a symbol is not part of a named pattern variable then we *)
(* only treat it as a variable that is structural in nature if *)
(* structuralQ is True for that symbol. If it is structural then*)
(* the eqns must be true whatever the value of this symbol. Thus*)
(* we treat it as a "solve always" type of variable in our mixed*)
(* solve. *)
dissectSemanticPattern @ symb_Symbol :=
(AppendTo[solveAlwaysVars, symb];
symb) /; structuralQ @@ fromInert @ Hold @ symb
(* Return anything else, e.g. Plus, 4, Times, Log. *)
dissectSemanticPattern @ other_ := other
(*--------------------------------------------------------------*)
(* This function is used to strip out the conditions in the rhs *)
(* of a pattern that we are transforming. We must strip out all *)
(* conditions at only the top level. *)
stripTopCondition @
inert`System`Condition[expr_, cond_]:=
(AppendTo[ conditionList, cond ];
stripTopCondition @ expr)
stripTopCondition[expr_]:= expr;
(*##############################################################*)
(* Transform Semantic Rules to Syntactic Rules. *)
(*##############################################################*)
(* This restricts Semantic to only wrapping Blank[head], *)
(* Pattern[symb,...], PatternTest[...] and Condition[...]. It *)
(* also transforms nested Semantics and Sequences of Semantics. *)
containsSemanticQ = containsQ @ Semantic;
containsUnAllowedPatternsQ = containsQ @
(BlankSequence | BlankNullSequence | Repeated | RepeatedNull |
Alternatives | HoldPattern | Optional );
Semantic @ semPatt_?containsUnAllowedPatternsQ :=
Message @ Semantic::badPatterns;
Semantic @ semPatt_?containsSemanticQ :=
(Message @ Semantic::nestedSemantics;
Semantic[semPatt /. (HoldPattern @ Semantic)[a___] -> a])
Semantic[a_,b__] :=
(Message @ Semantic::splitSemantics;
Sequence @@ Semantic /@ {a,b})
(*--------------------------------------------------------------*)
(* SemanticToSyntactic just calls the auxiliary function with *)
(* the correct arguments. It threads over Lists. *)
SemanticToSyntactic[lhs_?containsSemanticQ :> rhs_, opts___?OptionQ] :=
semanticToSyntacticAux[lhs,rhs,opts]
SemanticToSyntactic[lhs_?containsSemanticQ -> rhs_, opts___?OptionQ] :=
semanticToSyntacticAux[lhs,Evaluate @ rhs,opts]
SemanticToSyntactic[rules_List, opts___?OptionQ] :=
SemanticToSyntactic[#,opts]& /@ rules
SemanticToSyntactic[other_,___] := other
SetAttributes[SemanticToSyntactic,HoldFirst];
(*--------------------------------------------------------------*)
(* We set up this block so we can build up equations, solveVars *)
(* and solveAlwaysVars without having to explicitly pass them *)
(* to functions that change them. *)
(* hold everything so NOTHING can get evaluated. This is vitally*)
(* important since some variables that are contained in our *)
(* patterns that we are transforming, can and usually do have *)
(* values. *)
ClearAll @ semanticToSyntacticAux;
SetAttributes[semanticToSyntacticAux,HoldAll];
friendlyOff @ General::spell1;
semanticToSyntacticAux[lhs_, rhs_, opts___?OptionQ] :=
Block[
{equations = {},
solveVars = {},
solveAlwaysVars = {},
conditionList = {},
newLhs, intermediateLhs, (* Transformed lhs's *)
newRhs, intermediateRhs, (* Transformed rhs's *)
solutionForm, theRhs, isolateScope, (* these are dummy variables *)
eqns, SVars, SAVars, conds,
containsSolveVarsQ,freeOfSolveVarsQ, (* testing functions *)
verbosity, optimizingOn}, (* given options *)
verbosity = Verbose /. {opts} /. Options @ Semantica;
optimizingOn = Optimizing /. {opts} /. Options @ Semantica;
friendlyOn @ General::spell1;
(* This function-call sets equations, solveVars, *)
(* solveAlwaysVar and conditionList. These are dynamically *)
(* scoped since it would be awkward to pass them around *)
(* while performing pattern surgery. *)
intermediateLhs = toInert @ lhs /.
inert`Semantica`Semantic @ a_ :> dissectSemanticPattern @ inert`Semantica`Semantic @ a;
verbosePrint @ intermediateLhs;
(* This cleans up the accumulated variables *)
solveVars = Union @ solveVars;
solveAlwaysVars = Union @ solveAlwaysVars;
verbosePrint @ solveVars;
verbosePrint @ solveAlwaysVars;
(* If a pattern variable appears both inside a semantic and *)
(* outside a semantic then we treat it non-linearly and *)
(* delete it from the variables to be solved for. *)
solveVars = DeleteCases[solveVars, ! FreeQ[intermediateLhs, inert`System`Pattern[#,_]]& ];
verbosePrint @ solveAlwaysVars;
If[solveVars === {}, Message @ Semantica::noSolution];
(* The following just strips out any conditions on the lhs *)
(* that involve our semantic pattern variables. *)
freeOfSolveVarsQ = freeOfQ [Alternatives @@ solveVars];
containsSolveVarsQ = containsQ[Alternatives @@ solveVars];
newLhs = intermediateLhs //.
inert`System`Condition[ patt_, cond_?containsSolveVarsQ] :>
patt /; (AppendTo[conditionList, cond]; True );
verbosePrint @ newLhs;
(* We need to perform the same striping of conditions on the*)
(* rhs, but only at the top level. *)
intermediateRhs = stripTopCondition @ toInert @ Unevaluated @ rhs;
verbosePrint @ intermediateRhs;
(* Put equations and conditionList into a form for constructing solutions *)
equations = And @@ Union @ equations;
conditionList = And @@ Union @ conditionList;
verbosePrint @ equations;
verbosePrint @ conditionList;
Optimizable :=
( newEqns = Map[activateSystemSymbols, equations, {-1}, Heads->True];
reductions = Reduce[ newEqns, solveVars]//.
(h:Equal|Unequal)[l_?freeOfSolveVarsQ , r_?containsSolveVarsQ]:> h[r,l];
verbosePrint @ reductions;
(Head @ reductions =!= Reduce) &&
FreeQ[reductions, (Equal|Unequal)[_ , _?containsSolveVarsQ]]
);
verbosePrint @ Optimizable;
If[solveAlwaysVars === {} && optimizingOn && Optimizable ,
constructOptimizedSolution,
constructSolveEveryTimeSolution]
]
(*--------------------------------------------------------------*)
(* This code produces compiled code through reduce. If the eqns *)
(* are deemed to be optimizable then the solution that reduce *)
(* returns will be used to solve the system for any inputs. *)
(* These solutions and conditions are then transformed into *)
(* definitions. Note this can be a dangerous thing to do because*)
(* it tries to figure out the solution for general inputs and *)
(* therefore could avoid performing side effects etc. *)
(* Only system functions are allowed to be active during the *)
(* reduce. If a user defined function is meant to be active it *)
(* will have no effect anyway inside the reduce because reduce *)
(* only uses Mathematica's own algorithms. *)
ClearAll[constructOptimizedSolution];
constructOptimizedSolution := fromInert @ generateRules @ reductions;
generateRules @ solutions_Or :=
With[{solutionListName = Unique @ "Global`solutionList$"},
VerbosePrint[conditionList];
conditionList = And[conditionList,inert`System`AppendTo[solutionListName,intermediateRhs]];
VerbosePrint[conditionList];
Join[
{RuleDelayed @@ {inert`System`HoldPattern @ newLhs ,
inert`System`Condition[$ClearSolutionList, inert`System`Set[solutionListName ,{}]]}},
generateRulesAuxMultiple /@ Reverse [ List @@ solutions ],
{RuleDelayed @@ {inert`System`HoldPattern @ newLhs ,
inert`System`Condition[inert`Semantica`CleanUpSolutions[solutionListName],
inert`System`UnsameQ[solutionListName,{}]
]}
}
]
]
generateRules @ solutions_ := generateRulesAux /@ {solutions};
generateRulesAux @ solution_And := filterSolution [ List @@ solution ];
generateRulesAux @ solution_ := filterSolution @ {solution};
mergeConditions = {
inert`System`Condition [ inert`System`Condition[e_,c1_], c2_] :> inert`System`Condition[e, c1 && c2],
inert`System`Pattern [s_Symbol, inert`System`Condition[e_,c1_]] :> inert`System`Condition[inert`System`Pattern[s,e],c1],
inert`System`Condition [e_, True] :> e};
filterSolution @ solution_List :=
Module[{answers,conds},
answers := Cases[solution, Alternatives @@ solveVars == _ ];
conds := Cases[solution, (Equal|Unequal)[b_?freeOfSolveVarsQ ,_]];
If[ (Length @ Join[answers, conds] === Length @ solution) &&
(Length @ answers === Length @ solveVars),
generateSingleRule[answers,conds],
Sequence @@ {}]
]
generateSingleRule[answers_,conds_]:=
With[{bindings = answers /. {Equal -> inert`System`Set},
lhsConds = And @@ conds /. {Equal -> inert`System`SameQ, Unequal -> inert`System`UnsameQ}},
RuleDelayed @@
{ inert`System`HoldPattern @ inert`System`Condition[newLhs, lhsConds] //. mergeConditions,
inert`System`With[bindings, inert`System`Condition[intermediateRhs,conditionList]]}]
(*--------------------------------------------------------------*)
(* This is the construction we use when there are multiple *)
(* generic solutions to our problem *)
generateRulesAuxMultiple @ solution_And := filterSolutionMultiple [ List @@ solution ];
generateRulesAuxMultiple @ solution_ := filterSolutionMultiple @ {solution};
filterSolutionMultiple @ solution_List :=
Module[{answers,conds},
answers := Cases[solution, Alternatives @@ solveVars == _ ];
conds := Cases[solution, (Equal|Unequal)[_?freeOfSolveVarsQ ,_]];
If[ (Length @ answers + Length @ conds === Length @ solution) &&
(Length @ answers === Length @ solveVars),
generateSingleRuleMultiple[answers,conds],
Sequence @@ {}]
]
generateSingleRuleMultiple[answers_,conds_]:=
With[{bindings = answers /. {Equal -> inert`System`Set},
lhsConds = And @@ conds /. {Equal -> inert`System`SameQ, Unequal -> inert`System`UnsameQ}},
RuleDelayed @@
{ inert`System`HoldPattern @ inert`System`Condition[newLhs, lhsConds] //. mergeConditions,
inert`System`With[bindings, inert`System`Condition[$CollectingSolutions,conditionList]]}]
(*--------------------------------------------------------------*)
(* This is the construction we use when Solve has to be called *)
(* every time. It is generally safer because it only works out *)
(* the solutions once it has all the inputs. *)
constructSolveEveryTimeSolution := (
newRhs =
With[{theSolution = hold @@ ToHeldExpression @ "solution",
eqns = equations,
SVars = solveVars,
SAVars = solveAlwaysVars,
conds = conditionList,
theRhs = intermediateRhs},
With[{isolateScope = Join[solveVars,{theSolution}]},
hold @ Module[isolateScope,
(Unevaluated @ theRhs /. theSolution) /;
{} =!= (theSolution = SolveWithConditions[eqns, SVars, SAVars, conds]) ]]];
{RuleDelayed @@ fromInert @ flattenhold [hold @@ {HoldPattern @@ {newLhs},newRhs}]});
(*--------------------------------------------------------------*)
(* We set up some auxiliary functions so we can evaluate the *)
(* Semantic Parts of the lhs of assignments as they should be. *)
SetAttributes[{evaluateSemanticParts, trueHead}, HoldAll];
trueHead @ HoldPattern[HoldPattern] @ expr_ := trueHead @ expr
trueHead @ HoldPattern[Literal] @ expr_ := trueHead @ expr
trueHead @ HoldPattern[Unevaluated] @ expr_ := trueHead @ expr
trueHead @ HoldPattern[f_] @ expr___ := f
trueHead @ HoldPattern @ f_ := f
evaluateSemanticParts @ expr_ :=
With[{f = trueHead @ expr},
With[{theAttributes = Attributes @ f},
Block[{f},
Attributes @ f = theAttributes;
Hold @@ {expr}]]]
(*###############################################################*)
(* OVERIDE Standard behavior for assignments and replacements. *)
(*###############################################################*)
(* This redefines Replace, ReplaceAll, ReplaceRepeated, Dispatch *)
(* , Set and SetDelayed so that they can use semantic rules and *)
(* behave exactly as expected. Also overrides the warning message*)
(* generated when using a Semantic directly inside an Optional. *)
ruleActive = False;
containsSemanticPatternQ = containsQ[HoldPattern[Semantic][___]];
wasProtected =
Unprotect[Replace, ReplaceAll, ReplaceRepeated, Dispatch,
Set, SetDelayed, TagSet, TagSetDelayed, Message];
Replace [expr_, rules_ ? containsSemanticPatternQ]:=
Block[{newrules = SemanticToSyntactic @ rules,
ruleActive = False},
Replace [expr, newrules]] /; ruleActive
ReplaceAll [expr_, rules_ ? containsSemanticPatternQ]:=
Block[{newrules = SemanticToSyntactic @ rules,
ruleActive = False},
ReplaceAll [expr, newrules]] /; ruleActive
ReplaceRepeated [expr_, rules_ ? containsSemanticPatternQ]:=
Block[{newrules = SemanticToSyntactic @ rules,
ruleActive = False},
ReplaceRepeated [expr, newrules]] /; ruleActive
Dispatch @ rules_ ? containsSemanticPatternQ :=
Block[{newrules = SemanticToSyntactic @ rules,
ruleActive = False},
Dispatch @ newrules] /; ruleActive
HoldPattern @ (lhs_ ? containsSemanticPatternQ = rhs_) :=
Block[{newrules = Function[new, SemanticToSyntactic[new -> rhs], {HoldAll}] @@ evaluateSemanticParts @ lhs,
ruleActive = False},
(MySetDelayed @@ # &) /@ newrules;] /; ruleActive
HoldPattern @ (lhs_ ? containsSemanticPatternQ := rhs_) :=
Block[{newrules = Function[new, SemanticToSyntactic[new :> rhs], {HoldAll}] @@ evaluateSemanticParts @ lhs,
ruleActive = False},
(MySetDelayed @@ # &) /@ newrules;] /; ruleActive
SetAttributes[MySetDelayed,HoldAllComplete];
MySetDelayed[HoldPattern[HoldPattern] @ lhs_, rhs_]:= SetDelayed[lhs,rhs]
(* Can't have a condition on the rhs. of a tagged assignment.
HoldPattern @ (tag_ /: lhs_ ? containsSemanticPatternQ = rhs_) :=
Block[{newrules = SemanticToSyntactic[ lhs :> rhs ],
ruleActive = False},
(TagSetDelayed @@ Flatten[hold @@ {hold @ mine,hold @@ #},2,hold]&) /@
newrules;] /; ruleActive
HoldPattern @ (tag_ /: lhs_ ? containsSemanticPatternQ := rhs_) :=
Block[{newrules = SemanticToSyntactic[ lhs :> rhs ],
ruleActive = False},
(TagSetDelayed @@ Flatten[hold @@ {hold @ mine, hold @@ #},2,hold]&) /@
newrules;] /; ruleActive
*)
HoldPattern @ Message[General::optb, HoldPattern @ HoldForm @ Semantic @ _, ___]:=Null
ruleActive = True;
Protect @ Evaluate @ wasProtected;
(*--------------------------------------------------------------*)
End[]; (* Private *)
Protect [];
EndPackage[];