This is SupCode.m in view mode; [Download] [Up]
(* :Title: Supporting Routines *)
(* :Authors: Brian Evans, James McClellan *)
(*
:Summary: To provide routines that Mathematica should have.
Many are borrowed from Lisp.
*)
(* :Context: SignalProcessing`Support`SupCode` *)
(* :PackageVersion: 2.6 *)
(*
:Copyright: Copyright 1989-1991 by Brian L. Evans
Georgia Tech Research Corporation
Permission to use, copy, modify, and distribute this software
and its documentation for any purpose and without fee is
hereby granted, provided that the above copyright notice
appear in all copies and that both that copyright notice and
this permission notice appear in supporting documentation,
and that the name of the Georgia Tech Research Corporation,
Georgia Tech, or Georgia Institute of Technology not be used
in advertising or publicity pertaining to distribution of the
software without specific, written prior permission. Georgia
Tech makes no representations about the suitability of this
software for any purpose. It is provided "as is" without
express or implied warranty.
*)
(* :History: *)
(* :Keywords: list processing, sequences, number theory, set theory *)
(* :Source: *)
(* :Warning: *)
(* :Mathematica Version: 1.2 or 2.0 *)
(* :Limitation: *)
(*
:Functions: AllSubsets
Arrow2D
AssociateItem
Assuming
CirclePS
Combine
ComplexQ
ComplexTo2DCoord
ComplexTo2DCoordList
ConstantQ
ConstantTerm
Dialogue
Element
EmptyQ
GenerateCode
GeneratePattern
GenerateSymbol
GetAllExponents
GetAllFactors
GetArgs
GetRoot
GetRootList
GetShiftFactor
GetStateField
GetVariables
GetValue
HasAttributes
ImaginaryQ
InRange
InfinityQ
InformUserQ
ListQ
MixedPolynomialQ
MyApart
MyCollectAll
MyFreeQ
MyMessage
MyTogether
NegExponent
NormalizedQ
PatternQ
PointwisePlot
PrintIt
ProtectIt
RationalQ
RationalFunctionQ
RationalPolynomialQ
RealQ
RealValuedQ
RemoveOptions
ReplaceWith
RuleAppliesQ
SameFormQ
Second
SetExclusion
SetStateField
StripPackage
SubsetQ
TableLookup
Third
ToCollection
ToList
UnprotectIt
VariableQ
ZeroQ
ZPolynomial
*)
If [ ! TrueQ[ $VersionNumber >= 2.0 ],
$notloaded = ! MemberQ[$ContextPath, "SignalProcessing`Support`SupCode`"],
$notloaded = ! MemberQ[$Packages, "SignalProcessing`Support`SupCode`"];
Unprotect[ ListQ ];
Clear[ ListQ ];
$NewMessage[General, "spell"];
$NewMessage[General, "spell1"];
Off[ General::spell ];
Off[ General::spell1 ];
$NewMessage[Set, "write"];
$NewMessage[Set, "wrsym"];
$NewMessage[SetDelayed, "write"];
Off[ SetDelayed::write ];
Off[ Set::write ];
Off[ Set::wrsym ] ]
(* B E G I N P A C K A G E *)
BeginPackage[ "SignalProcessing`Support`SupCode`" ]
(* U S A G E I N F O R M A T I O N *)
AllSubsets::usage =
"AllSubsets[set] returns a list of all subsets of set, \
including the null set {}. \
The original set must be a lis."
Arrow2D::usage =
"Arrow2D[tail, plotwidth, plotheight] returns a graphics object \
that is an arrow starting at tail, pointing upwards, of \
length plotheight. \
The length of the tail can be controlled by an optional \
fourth parameter."
AssociateItem::usage =
"AssociateItem[item, lookuplist, newlist] finds the location of \
item in the lookuplist and returns the element of newlist in \
that position. \
If item is not is lookup list, Null is returned. \
If item is a list, then a list of associations is returned."
Assuming::usage =
"Assuming[condition] keeps track of assumptions made during \
a calculation. \
Assuming[All] gives all of the current assumptions. \
Assuming[condition, True] prints the condition if it is not True. \
Assuming[] removes all current assumptions."
CirclePS::usage =
"CirclePS[r] and CirclePS[r, p] will return a graphics object, \
a circle of radius r with plotstyle p. \
CirclePS makes use of the Circle primitive."
Combine::usage =
"Combine[object, joindata] sets the value of object to the \
joining of object with joindata; however, if object has no \
value, then object is set to joindata."
ComplexQ::usage =
"ComplexQ[z] returns True if z is a complex number, False otherwise."
ComplexTo2DCoord::usage =
"ComplexTo2DCoord[x] returns the two-dimensional coordinate \
corresponding to the complex form of x. \
That is, a pair of values in the form { Re[x], Im[x] } is returned."
ComplexTo2DCoordList::usage =
"ComplexTo2DCoordList[zlist] returns a list of coordinates \
corresponding to the complex form of each element in zlist. \
That is, zlist is mapped through ComplexTo2DCoord."
ConstantQ::usage =
"ConstantQ[x] returns True if x is always constant. \
If x is an atom, then x is constant it is a number or it x has \
a Constant attribute. \
If x is a function of the form f[arg1, arg2, ...], then x is \
considered to be constant if arg1, arg2, ..., are constant."
ConstantTerm::usage =
"ConstantTerm[expr, x] returns the constant term of the \
expression expr."
Dialogue::usage =
"Dialogue is an option for all of the symbolic transforms, the \
differential/difference equations solvers, and more. \
Possible settings are False, True, or All, for no, partial, or \
full justification. \
In the case of symbolic transforms, a setting of True or All will \
cause the rule base to describe strategies being applied to compute \
the transform as well as the functions (if any) which it could not \
transform. \
If it set to All, then the rule base will also display each step \
of the transform reasoning."
Element::usage =
"Element[list, n] returns the nth element of list. \
Also, Element[l1, l2, ..., n] returns ln."
EmptyQ::usage =
"EmptyQ[packet] returns True the packet of data is empty."
GenerateCode::usage =
"GenerateCode[object] converts object to a string (if necessary) \
and then evaluates it (translates it to Mathematica code)."
GeneratePattern::usage =
"GeneratePattern[namestring] generates a symbol with the name \
equal to namestring followed by an underscore, which makes the \
object be a pattern which can be used for pattern matching. \
For example, GeneratePattern[\"a\"] yields the pattern (a_)."
GenerateSymbol::usage =
"GenerateSymbol[namestring], GenerateSymbol[namestring, trailer], \
and GenerateSymbol[namestring, trailer, header], generate a \
symbol by concatenating header, namestring, and trailer."
GetAllExponents::usage =
"GetAllExponents[expr, x] returns all exponents of the \
term x in the expression expr. \
GetAllExponents[z^3 + 2 z^6, z] returns {6, 3}."
GetAllFactors::usage =
"GetAllFactors[expr, x] returns all factors of the \
term x in the expression expr. \
GetAllFactors[z^3 + 2 z^6, z] returns {1, 2}. \
GetAllFactors[z^-3 + 2 z^-6, z] returns {1/2, 1}."
GetArgs::usage =
"GetArgs[function] returns the argument(s) of the function. \
For example, GetArgs[ Bogus[1,2,3] ] would return 1,2,3. \
If the programmer only wishes to replace the head of a function \
with another, then use Apply instead of GetArgs. \
This function is similar to ToCollection."
GetOperatorVariables::usage =
"GetOperatorVariables[op] returns the variable(s) in the \
parameterized operator op. \
By default, GetOperatorVariables[ op[par1, par2, ...] ] \
returns the first parameter, par1."
GetRoot::usage =
"GetRoot[rule] extracts the value from an expression like \
{z -> 0.}, which is 0. in this case."
GetRootList::usage =
"GetRootList[p, x] returns a list of the approximate numerical roots \
of expression p, a function of x, with infinite roots removed. \
GetRootList[p, x, filter] applies filter to the list of roots \
returned by the Solve function (defaults to N)."
GetShiftFactor::usage =
"GetShiftFactor[expr, x] returns a list containing the common
shift factor in the variable x and a normalized version of expr. \
For example, GetShiftFactor[ (2 s + 2 b + c) Exp[s + b + Pi], s] \
returns {b, 2 Exp[Pi + b + s] (b + c/2 + s)}."
GetStateField::usage =
"GetStateField[state, field] returns the value of the slot \
field n the list state."
GetVariables::usage =
"GetVariables[expr] returns a list of all of the variables in \
the expression expr. \
See VariableQ for the definition of a variable."
GetValue::usage =
"GetValue[f[n], n, n0] finds the numeric value of f[n] at n = n0 \
and GetValue[f[n1,n2], {n1,n2}, {n01, n02}] finds the numeric \
value of f[n1,n2] at n1 = n01 and n2 = n02. \
When the first argument has the variables embedded in it, \
two arguments are sometimes enough: GetValue[ object, n0 ]. \
This is true when the object is an abstract signal."
HasAttributes::usage =
"HasAttributes[symbol, attribute1, attribute2, ...] returns True \
if the evaluation of symbol is another symbol and the attributes \
to be checked are a subset of the attributes of this other symbol. \
HasAttributes[Plus, {Listable, Orderless}] would return True."
ImaginaryQ::usage =
"ImaginaryQ[z] returns True if z is a number whose real part is zero."
InRange::usage =
"InRange[a, b, c, amin, cmax, leftcompare, rightcompare] returns \
True if b in between a and c. \
The inclusiveness of the interval a to c is determined by the \
arguments leftcompare and rightcompare, each of which defaults to \
LessEqual. \
So, InRange[a, b, c] returns True if a <= b <= c. \
Non-numeric values, like Infinity, can be used for amin and cmax, \
which default to -Infinity and +Infinity, respectively."
InfinityQ::usage =
"InfinityQ[a] will return True if a is Infinity, -Infinity, \
ComplexInfinity, DirectedInfinity[], or DirectedInfinity[r]."
InformUserQ::usage =
"InformUserQ[x] returns True if the options in object x contain \
Dialogue -> All or Dialogue -> True. \
It also returns True if x is All or True."
ListQ::usage =
"ListQ[expr] gives True if expr is a List, and False otherwise."
MixedPolynomialQ::usage =
"MixedPolynomialQ[p] and MixedPolynomialQ[p,x] return \
return True if p is a polynomial in negative and positive \
(mixed) powers of x. \
Note that rational numbers like 5/6 and 1 are polynomials. \
MixedPolynomialQ[x + x^-1, x] is True."
MyApart::usage =
"MyApart[ rational_polynomial, x ] decomposes the rational \
polynomial into a sum of fractions whose numerators are of \
the form (x + b)^n where b is a constant and n is an integer. \
MyApart[rational_polynomial, x, filter] specifies a filter to be \
placed on the output of the Solve command used to root the \
denominator: Identity for rational and N for real-valued roots. \
The default is Identity. \
In Mathematica 1.2, MyApart is about 25 times slower than Apart."
MyCollectAll::usage =
"MyCollectAll[ expression, var ] attempts to collect all \
subexpressions of expression in terms of var."
MyFreeQ::usage =
"MyFreeQ[expr, form], when form is not a list, yields True if no \
subexpression in expr matches form. \
If form is a list, then True is returned if expr is free of \
each element of form. \
This is similar to MyFreeQ[expr, form1, form2, ...] which expands to \
MyFreeQ[expr, form1] and MyFreeQ[expr, form2] and ...."
MyMessage::usage =
"MyMessage[message-label, return-value, arg1, arg2, ...] first calls \
Message[message-label, arg1, arg2, ...] and then returns return-value."
MyTogether::usage =
"MyTogether[x] puts the expression x over a common denominator. \
This is the same as Together[x] without the effect of Cancel. \
This function is compatible with DFT expressions."
NegExponent::usage =
"NegExponent[poly, x] returns the maximum exponent of x^-1."
NormalizedQ::usage =
"NormalizedQ[e,x] gives True if the constant term is one \
or zero, and gives False otherwise."
NullPlot::usage =
"NullPlot is a 2-d graphics object which only contains the origin."
PatternQ::usage =
"PatternQ[expr] returns True if the head of expr is Pattern."
PointwisePlot::usage =
"PointwisePlot[coordlist, text] and \
PointwisePlot[coordlist, text, multiplicitytext] \
will plot the coordinates in coordlist as text \
for 2-D and 3-D graphics. \
An optional fourth argument specifies the size of the font to use. \
For multiple occurrences of the same coordinate,\
the object multiplicitytext is displayed. \
The last two arguments are usually symbols, numbers, or \
FontForm objects."
PrintIt::usage =
"PrintIt[graphics, printer] will print out graphics on a printer. \
If the printer is not specified, the default printer is used."
ProtectIt::usage =
"ProtectIt[expr] evaluates expr. \
If it evaluates to a symbol, that symbol will be write protected. \
Rules can be written for that symbol, \
but values can no longer be assigned to it."
RationalQ::usage =
"RationalQ[m] returns True if m is a rational number. \
If m is an integer, then this function also return True, \
since the set of integers are a subset of rationals."
RationalFunctionQ::usage =
"RationalFunctionQ[f,x] returns True if expression f is of the form \
f = g(x) / h(x), where h(x) depends on x but g(x) does not have \
to depend on x. \
For example, 1 / ( x + 1 ) is a rational function \
in x but x^3 + x^2 + x / ( x + 1) is not."
RationalPolynomialQ::usage =
"RationalPolynomialQ[p] and RationalPolynomialQ[p,x] return \
True if p is a rational polynomial in x. \
Note that rational numbers like 5/6 and 1 are also \
rational polynomials."
RealQ::usage =
"RealQ[z] returns True if z is a floating-point number \
(has a head of Real), False otherwise. See RealValuedQ."
RealValuedQ::usage =
"RealValuedQ[z] gives True if z is a number whose imaginary \
component is 0, and gives False otherwise. See RealQ."
RemoveOptions::usage =
"RemoveOptions[optionlist, options] removes the options \
from optionlist."
ReplaceWith::usage =
"ReplaceWith[oldexpr, newexpr] is a generalized way to specify \
a substitution when the substitution may be either atomic \
and a list of substitutions."
RuleAppliesQ::usage =
"RuleAppliesQ[expr, rule] returns True if rule applies to expr. \
RuleAppliesQ[head[expr1, expr2, ..., exprn], rule, head] returns \
True if the rule applies to each expression expr1, expr2, ..., \
exprn."
SameFormQ::usage =
"SameFormQ[pattern, expr1, expr2, ...] returns True if every \
expression matches pattern via MatchQ. \
Once an expression does not match, \
this function immediately returns False."
Second::usage =
"Second[list] returns the second element of list."
SetExclusion::usage =
"SetExclusion[set1, set2, ...] returns a set equal to the union \
of the sets minus the intersection of the sets."
SetStateField::usage =
"SetStateField[state, field, value] will return a new state, \
which is a copy of the list state except that the value of \
the slot field will be equal to value."
SPfunctions::usage =
"SPfunctions maintains a current list of those new routines \
that have been loaded from the signal processing packages."
SPLessGreaterRules::usage =
"SPLessGreaterRules are a collection of rules for simplifying \
expressions involving inequalities."
SPoperators::usage =
"SPoperators maintains a current list of the new mathematical \
operators that have been loaded from the signal processing packages."
SPsignals::usage =
"SPsignals maintains a current list of those new signals \
(mathematical functions) that have been loaded from the \
signal processing packages."
SPSimplificationRules::usage =
"SPSimplificationRules are a collection of simplification rules \
that are not carried out by Simplify. \
These rules require too much overhead to encode them directly \
into Mathematica. \
See also SPSimplify."
StripPackage::usage =
"StripPackage[symbol] returns the symbol (as a string) after its \
context has been removed. \
To remove the package definition from every symbol in expression, \
use MapAll[StripPackaage, expression]."
SubsetQ::usage =
"SubsetQ[set1, set2, set3, ...] returns True if set1 is a subset \
of set2 and set2 is a subset of set3, etc."
TableLookup::usage =
"TableLookup[index, hlist, len, val] returns hlist[[index]] \
if index is between 1 and len, inclusive; otherwise, val is \
returned."
Third::usage =
"Third[list] returns the third element of list."
ToCollection::usage =
"ToCollection[expr] strips the head off of arg and returns \
the argument of expr as a collection. \
ToCollection returns an object that is a sequence, \
which is represented in Mathematica 1.2 as (a1, a2, ...) \
and in Mathematica 2.0 as Sequence[a1, a2, ...]. \
So, it provides a unified way of generating collections (sequences)."
ToList::usage =
"ToList[arg] returns arg if arg is a list. \
Otherwise, List[arg] is returned. \
ToList[arg1, arg2, ...] returns List[arg1, arg2, ...]."
UnprotectIt::usage =
"UnprotectIt[expr] evaluates expr. \
If it evaluates to a symbol, \
write protection will be removed for that symbol."
VariableQ::usage =
"VariableQ[x] returns True if x is a symbol that \
(1) does not have a numerical value associated with it and
(2) does not have its Constant attribute enabled. \
Pi fails the first test, so it is not considered a variable. \
A variable can also have the form of C[n] where n is an integer \
and C is a symbol whose Constant attribute is enabled."
ZeroQ::usage =
"ZeroQ[x] returns True if x is 0 or 0.0"
ZPolynomial::usage =
"ZPolynomial[m, n] is an mth order polynomial in the discrete \
variable n defined by the product of (-n - k) for k = 0 ... m-1. \
The z-transform of the product of this polynomial and some function \
f[n] gives z^m times the mth derivative of F(z)."
(* E N D U S A G E I N F O R M A T I O N *)
Begin["`Private`"]
(* A L T E R E X I S T I N G F U N C T I O N S *)
(* And *)
Unprotect[And]
And/: Simplify[And[a1_, args__]] := Apply[And, Union[{a1, args}]]
Protect[And]
(* ClearAttributes *)
Unprotect[ClearAttributes]
SetAttributes[ClearAttributes, HoldFirst]
Protect[ClearAttributes]
(* Det *)
Unprotect[Det]
Det[x_?NumberQ] := x
Protect[Det]
(* Dot *)
Unprotect[Dot]
Dot[x_?NumberQ, y_?NumberQ] := x y
Protect[Dot]
(* Limit *)
If [ TrueQ[ $VersionNumber >= 2.0 ],
Unprotect[ Limit ];
Limit/: Options[Limit] := { Analytic -> True, Direction -> Automatic };
Protect[ Limit ] ]
(* SetAttributes *)
Unprotect[SetAttributes]
SetAttributes[SetAttributes, HoldFirst]
Protect[SetAttributes]
(* TeXForm *)
Unprotect[Re, Im]
Im/: Format[ Im[x_], TeXForm ] := StringForm["\\Im{m}(``)", x]
Re/: Format[ Re[x_], TeXForm ] := StringForm["\\Re{e}(``)", x]
Protect[Re, Im]
(* S I M P L I F I C A T I O N R U L E S *)
(* PositiveOrNegative *)
PositiveOrNegative[a_] := SameQ[Head[N[a]], Real]
(* For minimum/maximum operations *)
MinMaxRules = {
Min[t1_, t2_] :> t1 /; N[t1 < t2],
Min[t1_, t2_] :> t2 /; N[t1 > t2],
Max[t1_, t2_] :> t1 /; N[t1 > t2],
Max[t1_, t2_] :> t2 /; N[t1 < t2],
Min[a_ + b_, b_] :> a + b /; Negative[a],
Min[a_ + b_, b_] :> b /; Positive[a],
Max[a_ + b_, b_] :> b /; Negative[a],
Max[a_ + b_, b_] :> a + b /; Positive[a]
}
If [ ! TrueQ[ $VersionNumber >= 2.0 ], (* built into 2.0's Simplify *)
MinMaxRules = MinMaxRules ~Join~ {
Min[a_, a_] :> a,
Max[a_, a_] :> a
} ]
(* For the less than operation *)
LessRules = {
Less[Max[a_, b__], a_] :> Less[Max[b], a],
LessEqual[Max[a_, b__], a_] :> LessEqual[Max[b], a],
Less[Times[-1, b_], 0] :> Greater[b, 0],
LessEqual[Times[-1, b_], 0] :> GreaterEqual[b, 0]
}
(* For the greater than operation *)
GreaterRules = {
Greater[Min[a_, b__], a_] :> Greater[Min[b], a],
GreaterEqual[Min[a_, b__], a_] :> GreaterEqual[Min[b], a],
Greater[Times[-1, b_], 0] :> Less[b, 0],
GreaterEqual[Times[-1, b_], 0] :> LessEqual[b, 0]
}
(* For the absolute value operation *)
AbsRules = {
Abs[- a_] :> Abs[a],
Abs[x_?PositiveOrNegative y_] :> Abs[x] Abs[y]
}
If [ ! TrueQ[ $VersionNumber >= 2.0 ], (* built into 2.0's Simplify *)
AbsRules = AbsRules ~Join~ {
Re[Abs[a_]] :> Abs[a],
Im[Abs[a_]] :> 0,
Abs[Abs[a_]] :> Abs[a],
Abs[r_. Exp[ Complex[0, b_] a_. ] ] :> r /; PositiveOrNegative[a b r],
Abs[a_] :> a /; Positive[a],
Abs[a_] :> -a /; Negative[a]
} ]
(* For the real and imaginary operations *)
ReImRules = {
Re[- a_] :> - Re[a],
Im[- a_] :> - Im[a],
Conjugate[ Exp[ Complex[0, b_] a_. ] ] :> Exp[ Complex[0, -b] a ] /;
PositiveOrNegative[a b],
Conjugate[ ( a_. Conjugate[z_]^r_. + b_. )^s_. ] :>
( a z^r + b )^s /;
((r == 1) || (r == -1)) && ((s == 1) || (s == -1)) &&
PositiveOrNegative[a] && PositiveOrNegative[b],
Conjugate[a_ b_] :> Conjugate[a] Conjugate[b]
}
If [ ! TrueQ[ $VersionNumber >= 2.0 ], (* built into 2.0's Simplify *)
ReImRules = ReImRules ~Join~ {
Re[a_] :> a /; PositiveOrNegative[a],
Im[a_] :> 0 /; PositiveOrNegative[a],
Re[r_. Exp[ Complex[0, b_] a_. ] ] :> r Cos[b a] /;
PositiveOrNegative[a b r],
Im[r_. Exp[ Complex[0, b_] a_. ] ] :> r Sin[b a] /;
PositiveOrNegative[a b r],
Re[Im[a_]] :> Im[a],
Im[Re[a_]] :> 0,
Re[Re[a_]] :> Re[a],
Im[Im[a_]] :> 0,
Conjugate[Conjugate[x_]] :> x,
Conjugate[Re[x]] :> Re[x],
Conjugate[Im[x]] :> Im[x],
Conjugate[x_] :> x /; PositiveOrNegative[x]
} ]
(* For products of exponentials *)
TimesRules = {
a_^k_ b_^k_ :> 1 /; ( a == 1/b ) && PositiveOrNegative[k]
}
(* For exponential and logarithmic functions *)
ExpLogRules = {
base_^(c_. Log[base_, b_]) :> b^c,
Log[c_. Exp[b_]] :> Log[c] + b,
Log[base_, c_. base_^b_] :> Log[base, c] + b
}
If [ ! TrueQ[ $VersionNumber >= 2.0 ], (* built into 2.0's Simplify *)
ExpLogRules = ExpLogRules ~Join~ {
Exp[c_. Log[b_]] :> b^c,
Erf[-a_] :> -Erf[a],
Exp[ a_. Complex[0, b_] Pi ] :> Exp[ Mod[a b, 2] I Pi ] /;
RationalQ[a b] && ( (a b < 0) || (a b >= 2) )
} ]
(* Evenness and oddness of functions *)
EvenOddRules = {
Sign[-x_] :> -Sign[x],
BesselI[n_Integer, -x_] :> (-1)^n BesselI[n, x],
BesselJ[n_Integer, -x_] :> (-1)^n BesselJ[n, x]
}
If [ ! TrueQ[ $VersionNumber >= 2.0 ],
EvenOddRules = EvenOddRules ~Join~ {
Sin[-x_] :> -Sin[x],
Cos[-x_] :> Cos[x],
Tan[-x_] :> -Tan[x] } ]
(* For other simplifications *)
If [ TrueQ[ $VersionNumber >= 2.0 ],
OtherRules = {
( ((x_^l_.) t_)^k_ :> x^(l k) t^k /;
PositiveOrNegative[x] && PositiveOrNegative[l] &&
PositiveOrNegative[k] ) },
OtherRules = {
Sqrt[x_] :> I Sqrt[-x] /; x < 0,
Tan[Complex[0, b_] w_.] :> I Tanh[b w],
Sin[Complex[0, b_] w_.] :> I Sinh[b w],
Cos[Complex[0, b_] w_.] :> Cosh[b w] } ]
SPSimplificationRules =
Join[MinMaxRules, AbsRules, TimesRules, ReImRules,
ExpLogRules, OtherRules, EvenOddRules]
SPLessGreaterRules = Join[LessRules, GreaterRules]
(* M E S S A G E S *)
PointwisePlot::invalid = "Null coordinate list passed."
Dialogue::notvalid =
"The Dialogue option must be True, False, or All: `` is not valid."
(* G L O B A L S *)
NullPlot := Graphics [ PointSize[0.007] ]
(* NullPlot := Graphics [ Point[{0, 0}], DisplayFunction -> Identity ] *)
(* F U N C T I O N S *)
(* AllSubsets *)
AllSubsets[x_List] :=
Sort[ Map[Flatten, Distribute[Map[{{},{#1}}&, x], List]] ]
(* Arrow2D *)
Arrow2D[tail_, plotwidth_, plotheight_:1] :=
Arrow2D[tail, plotwidth, plotheight, plotheight]
Arrow2D[tail_, plotwidth_, plotheight_, length_] :=
Block [ {arrowleft, arrowright, head, xoffset, yoffset},
xoffset = 0.1 plotheight;
yoffset = 0.3 plotheight;
head = tail + { 0, length };
arrowleft = head - { xoffset, yoffset };
arrowright = head + { xoffset, - yoffset };
Graphics[ Line[{tail, head, arrowleft, arrowright, head}] ] ]
(* AssociateItem *)
AssociateItem[item_, lookuptable_, assoctable_] :=
Map[Function[var, AssociateItem[var, lookuptable, assoctable]], item] /;
ListQ[item]
AssociateItem[item_, lookuptable_, assoctable_] :=
If [ MemberQ[lookuptable, item],
assoctable [[ ToCollection[ToCollection[Position[lookuptable, item] ]] ]] ] /;
! ListQ[item]
(* Assuming *)
AssumingList = {}
Assuming[] := AssumingList = {}
Assuming[All] := Apply[And, AssumingList]
Assuming[True] := Null
Assuming[True, x_] := Null
Assuming[cond_] := AppendTo[AssumingList, cond]
Assuming[cond_, op_List] := Assuming[cond, SameQ[Replace[Dialogue, op], All]]
Assuming[cond_, True] :=
Block [ {},
Print[ "assuming ", cond ];
Assuming[cond] ]
Assuming[cond_, x_] := Assuming[cond]
(* CirclePS *)
CirclePS[r_] := Graphics[ Circle[{0, 0}, r] ]
CirclePS[r_, p_] := Graphics[ { p, Circle[{0, 0}, r] } ]
(* Combine *)
SetAttributes[Combine, {HoldFirst}]
Combine[object_, joindata_] :=
If [ ValueQ[object],
object = Sort[object ~Join~ joindata],
object = joindata ]
(* ComplexQ *)
ComplexQ[z_] := NumberQ[z] && SameQ[Head[z], Complex]
(* ComplexTo2DCoord and ComplexTo2DCoordList *)
ComplexTo2DCoord[z_] := { Re[z], Im[z] }
ComplexTo2DCoordList[zlist_] := Map[ ComplexTo2DCoord, zlist ]
(* ConstantQ *)
ConstantQ[x_?AtomQ] := NumberQ[x] || HasAttributes[x, Constant]
ConstantQ[f_[x__]] := Apply[And, Map[ConstantQ, List[x]]]
(* ConstantTerm *)
ConstantTerm[expr_, z_:Global`x] :=
Block [ {nonpropterms},
keepconstants[e_] := If [ MyFreeQ[e,z], e, 0 ];
nonpropterms = Coefficient[expr, z, 0];
If [ MyFreeQ[nonpropterms, z],
nonpropterms,
Map[keepconstants, nonpropterms] ] ]
(* Element *)
Element[h_[args__], i_?IntegerQ] := h[args] [[i]]
Element[x_?AtomQ, i_] := x
Element[x__, i_?IntegerQ] := ToList[x] [[i]]
(* EmptyQ *)
EmptyQ[x_?AtomQ] := False
EmptyQ[h_[]] := True
EmptyQ[h_[values__]] := False
(* GenerateCode *)
GenerateCode[code_] := ToExpression[ToString[code]]
(* GeneratePattern *)
GeneratePattern[name_] := GenerateSymbol[name, "_"]
(* GenerateSymbol *)
GenerateSymbol[name_] := GenerateCode[name]
GenerateSymbol[name_, trailer_] :=
GenerateCode[StringForm["````", name, trailer]]
GenerateSymbol[name_, trailer_, header_] :=
GenerateCode[StringForm["``````", header, name, trailer]]
(* GetArgs *)
GetArgs[h_[]] := Null
GetArgs[h_[x__][d__]] := d
GetArgs[h_[x__]] := x
GetArgs[e1_, e__] := ToCollection[ GetArgs[e1], GetArgs[e] ]
(* GetAllExponents and GetAllFactors *)
depthfirstsearch[expr_, lhs_, rule_] :=
Block [ {cur, i, len},
If [ AtomQ[expr],
If [ MatchQ[expr, lhs],
PrependTo[list, Replace[expr, rule]] ],
len = Length[expr];
For [ i = 1, i <= len, i++,
cur = expr[[i]];
If [ MatchQ[cur, lhs],
PrependTo[list, Replace[cur, rule]],
depthfirstsearch[cur, lhs, rule] ] ] ];
Null ]
depthdriver[expr_, lhs_, rule_] :=
Block [ {},
list = {};
depthfirstsearch[expr, lhs, rule];
list ]
GetAllExponents[ expr_, z_ ] :=
depthdriver[expr, (c_. z^n_.), (c_. z^n_. :> n) ]
GetAllFactors[ a_ + b_, z_ ] :=
Join[ GetAllFactors[a, z], GetAllFactors[b, z] ]
GetAllFactors[ c_ z_^n_. expr_, z_ ] :=
Prepend[ GetAllFactors[expr, z], c^Sign[n] /. Sign[x_] :> 1 ]
GetAllFactors[ expr_, z_ ] :=
depthdriver[expr, (c_. z^n_.), (c_. z^n_. :> c^Sign[n]) ] /.
( Sign[x_] :> 1 )
(* GetOperatorVariables *)
GetOperatorVariables[ h_[var_, rest___] ] := var
(* GetRoot *)
GetRoot[{}] := {} (* no roots *)
GetRoot[rule_] := Second[First[rule]]
(* GetRootList *)
goodroot[r_] := ! MatchQ[r, DirectedInfinity[___]]
GetRootList[p_, x_, filter_:N] :=
Select[ Map[ GetRoot, filter[ Solve[ p == 0, x ] ] ], goodroot ]
(* GetShiftFactor *)
commonFactor = 0
myMin[ x1_?RealValuedQ, x2_?RealValuedQ ] :=
Min[x1, x2]
myMin[ x1_?RealValuedQ, Complex[re2_,im2_] ] :=
Complex[myMin[x1, re2], im2]
myMin[ Complex[re1_,im1_], Complex[re2_,im2_] ] :=
Complex[myMin[re1,re2], myMin[im1,im2] ]
reduce[ 0, x_, term_ ] := term (* stopping conditions *)
reduce[ x_, 0, term_ ] := term
reduce[ x1_?NumberQ + rest1_., x2_?NumberQ + rest2_., term_ ] :=
reduce[ rest1, rest2, term + myMin[x1,x2] ]
reduce[ x1_. y_ + rest1_., x2_. y_ + rest2_., term_ ] :=
reduce[ rest1, rest2, term + myMin[x1,x2] y ] /;
NumberQ[x1] && NumberQ[x2] && ! NumberQ[y]
reduce[ a_, b_, term_ ] := term (* incomplete reduction *)
extractShift[ a_, b_, s_ ] :=
Block [ {shift},
shift = Expand[b/a];
If [ ValueQ[commonFactor],
commonFactor = reduce[shift, commonFactor, 0],
commonFactor = shift ];
a ( s + shift ) ]
GetShiftFactor[expr_, s_] :=
Block [ {normexpr, rules},
Clear[commonFactor];
rules = (a_. s + b_. :> extractShift[a, b, s]);
If [ ! TrueQ[ $VersionNumber >= 2.0 ],
rules = { (a_. s + b__) :> extractShift[a, Plus[b], s],
rules,
s :> extractShift[1, 0, s] } ];
normexpr = expr /. rules;
If [ ! ValueQ[commonFactor], commonFactor = 0 ];
{ commonFactor, normexpr } ]
(* GetStateField *)
GetStateField[state_List, field_] := state[[field]]
(* GetVariables *)
extractrules = { f_[x__][y__][z__] :> bogus[x, y, z],
f_[x__][y__] :> bogus[x, y],
(x_ -> y_) :> {},
(x_ :> y_) :> {} }
GetVariables[x_] :=
Union[ Select[ Level[x /. extractrules, Infinity], VariableQ ] ]
(* GetValue *)
GetValue[f_, n_Symbol, n0_] :=
Block [ {value},
value = N [ f /. n -> n0 ];
If [ NumberQ[value],
value,
N [ Limit[f, n -> n0] ] ] ]
GetValue[f_, {n1_Symbol, n2_Symbol}, {n01_, n02_}] :=
Block [ {value},
value = N [ f /. { n1 -> n01, n2 -> n02 } ];
If [ NumberQ[value],
value,
N[ Limit[ Limit[f, n1 -> n01], n2 -> n02] ] ] ]
(* HasAttributes *)
HasAttributes[symbol_, attrib1_, attribs__] :=
HasAttributes[symbol, {attrib1, attribs}]
HasAttributes[symbol_Symbol, attrib_] :=
Block [ {attributes, protected},
attributes = Attributes[Attributes];
Unprotect[Attributes];
ClearAttributes[Attributes, {HoldFirst, HoldAll, HoldRest}];
protected = If [ AtomQ[attrib],
MemberQ[Attributes[symbol], attrib],
SubsetQ[attrib, Attributes[symbol]] ];
SetAttributes[Attributes, attributes];
protected ]
(* ImaginaryQ *)
ImaginaryQ[z_] := NumberQ[z] && ZeroQ[Re[z]]
(* InRange, function will be automatically threaded if a,b,c are not atoms *)
SetAttributes[MyInRange, Listable]
InRange[a_, b_, c_, amin_:-Infinity, cmax_:Infinity, leftcompare_:LessEqual, rightcompare_:LessEqual ] :=
Apply[And,
ToList[MyInRange[a, b, c, amin, cmax, leftcompare, rightcompare]]]
MyInRange[a_, b_, c_, amin_, cmax_, leftcompare_, rightcompare_] :=
Which [ SameQ[a, amin] && SameQ[c, cmax],
True,
SameQ[a, amin],
SameQ[b, amin] || rightcompare[b, c],
SameQ[c, cmax],
SameQ[b, cmax] || leftcompare[a, b],
True,
leftcompare[a, b] && rightcompare[b, c] ]
(* InfinityQ *)
InfinityQ[e_List] := Apply[And, Map[InfinityQ, e]]
InfinityQ[DirectedInfinity[]] := True
InfinityQ[DirectedInfinity[r_]] := True
InfinityQ[a_] := False
(* InformUserQ *)
informuser[All] := True
informuser[True] := True
informuser[False] := False
informuser[x_] := False
InformUserQ[x_List] := informuser[Replace[Dialogue, x]]
InformUserQ[x_] := informuser[x]
(* ListQ-- it is an undocumented primitive in Mma 2.0+ *)
(* in 2.0, it does not always return True or False *)
ListQ[object_] := SameQ[Head[object], List]
(* MixedPolynomialQ *)
twosided[ c_. z_^r_., z_ ] := FreeQ[c, z] && IntegerQ[r]
twosided[ c_, z_ ] := FreeQ[c, z]
MixedPolynomialQ[c_] := MixedPolynomialQ[c, Global`x]
MixedPolynomialQ[x_?AtomQ, z_] := True
MixedPolynomialQ[Plus[a_, b__], z_] := Apply[And, Map[twosided[#1, z]&, {a, b}]]
MixedPolynomialQ[x_, z_] := twosided[x, z]
(* MyApart -- kludge around the way Apart does partial fractions *)
(* Root denominator and replace roots with symbols *)
MyApart[ratpoly_, x_, filter_:Identity] :=
Block [ {apart, denom, denomfactored, normfact, numer,
partfrac, rootlist, rootmult, rules},
numer = Numerator[ratpoly];
denom = Denominator[ratpoly];
normfact = Last[ CoefficientList[denom, x] ];
numer /= normfact;
denom /= normfact;
rootlist = Sort[ GetRootList[denom, x, filter] ];
{ denomfactored, rules } = multiplicityform[rootlist, x];
apart = Apart[numer / denomfactored, x];
partfrac = apart /. rules;
partfrac /. ( a_. / (b_ c_) :> a / ( Together[b] c ) /;
FreeQ[b, x] && ! FreeQ[c, x] ) ]
multiplicityform[ roots_, x_ ] :=
Block [ {count = 1, cur, denom = 1, i, last,
length, sublist = {}, sym = 1},
Clear[localvar]; (* localvar is global to package *)
length = Length[roots];
last = First[roots];
For [ i = 2, i <= length, i++,
cur = roots[[i]];
If [ SameQ[ cur, last ],
count++,
denom *= (x - localvar[sym])^count;
PrependTo[ sublist, localvar[sym] -> last ];
sym++;
count = 1 ];
last = cur ];
denom *= (x - localvar[sym])^count;
PrependTo[ sublist, localvar[sym] -> last ];
{ denom, sublist } ]
(* MyCollectAll *)
MyCollectAll[ Plus[term1_, terms__], x_ ] := Collect[ Plus[term1, terms], x ]
MyCollectAll[ h_[a_], x_ ] := h[ MyCollectAll[a,x] ]
MyCollectAll[ h_[a_, b__], x_ ] := Apply[h, Map[MyCollectAll[#1, x]&, {a, b}]]
MyCollectAll[ a_, x_ ] := a
(* MyFreeQ *)
MyFreeQ[expr_, {form_}] := FreeQ[expr, form]
MyFreeQ[expr_, {form1_, forms__}] := FreeQ[expr, form1] && MyFreeQ[expr, forms]
MyFreeQ[expr_, form_] := FreeQ[expr, form]
MyFreeQ[expr_, form1_, forms__] := FreeQ[expr, form1] && MyFreeQ[expr, forms]
(* MyMessage *)
SetAttributes[MyMessage, HoldFirst]
MyMessage[message_, return_] :=
Block [ {},
Message[message];
return ]
MyMessage[message_, return_, args__] :=
Block [ {},
Message[message, args];
return ]
(* MyTogether *)
MyTogether[ Plus[a_, b_, c__] ] := MyTogether[ Plus[MyTogether[Plus[a, b]], c] ]
MyTogether[ Plus[a_, b_] ] := MyTogether[ Numerator[a], Denominator[a], Numerator[b], Denominator[b] ]
MyTogether[ a_ ] := a
MyTogether[ a_, b_, c_, b_ ] := ( a + c ) / b
MyTogether[ a_, b_, c_, b_ d_ ] := ( a d + c ) / ( b d )
MyTogether[ a_, b_ d_, c_, d_ ] := ( a + b c ) / ( b d )
MyTogether[ a_, b_, c_, d_ ] := ( a d + b c ) / ( b d )
(* NegExponent *)
NegExponent[p_, x_:Global`x] := Exponent[p /. x -> x^-1, x]
(* NormalizedQ *)
NormalizedQ[e_, z_] :=
Block [ {leadingcoef},
leadingcoef = ConstantTerm[Expand[e], z];
TrueQ[( leadingcoef == 0 ) || ( leadingcoef == 1 )] ]
(* PatternQ *)
PatternQ[expr_] := SameQ[Head[expr], Pattern]
(* PointwisePlot *)
PointwisePlot[coordlist_, singtext_] :=
PointwisePlot[coordlist, singtext, singtext]
(* plots each unique set of coordinates. multiple occurrences of the *)
(* same coordinate are plotted as <text>(n), where n is the number of *)
(* occurrences. First, the coordinate list is sorted. A Null is *)
(* appended because the scanning function compares the current *)
(* coordinate with the last, so that Null forces the last coordinate *)
(* to be processed. After the pointwiseplot graphics commands are *)
(* built up, the resulting plot is returned as a graphics object. *)
(* The point size of the text defaults to 18. Supported font sizes *)
(* are 10, 12, 14, 18, 20, 24, ... *)
PointwisePlot[coordlist_, singtext_, multtext_, fontsize_:18] :=
Block [ {counter = 1, text, lastcoord = Null,
pointwiseplot = {}, ptsize, str},
ptsize = Round[fontsize];
Scan [ Function[ coord,
Which [ SameQ[lastcoord, Null], (* initial cond. *)
counter = 1;
lastcoord = coord,
SameQ[coord, lastcoord], (* multiple occur. *)
++counter,
True, (* plot it *)
str = If [ SameQ[counter, 1],
singtext,
multtext ];
text = If [ TrueQ[$VersionNumber >= 2.0],
FontForm[str, {"Bold", ptsize}],
FontForm[str, "Bold", ptsize] ];
AppendTo[ pointwiseplot,
Text[text, lastcoord] ];
counter = 1;
lastcoord = coord ] ],
Append[Sort[coordlist], Null] ];
Graphics[pointwiseplot] ] /;
! EmptyQ[coordlist]
PointwisePlot[coordlist_, singtext_, multtext_] :=
MyMessage[PointwisePlot::invalid, NullPlot] /;
EmptyQ[coordlist]
(* PrintIt *)
PrintIt[graphics_] :=
Display["!psfix | lpr", graphics]
PrintIt[graphics_, printer_] :=
Display[ToString[StringForm["!psfix | lpr -P``", printer]], graphics]
(* ProtectIt *)
ProtectIt[symbol_Symbol] := Apply[Protect, {symbol}]
(* RationalQ *)
RationalQ[z_Integer] := True
RationalQ[z_Rational] := True
RationalQ[z_] := False
(* RationalFunctionQ *)
RationalFunctionQ[f_, x_:Global`x] :=
( ! SameQ[Head[f], Plus] ) && ( ! MyFreeQ[Denominator[f], x] )
(* RationalPolynomialQ *)
RationalPolynomialQ[p_] :=
PolynomialQ[Numerator[p]] && PolynomialQ[Denominator[p]]
RationalPolynomialQ[p_, x_] :=
PolynomialQ[Numerator[p], x] && PolynomialQ[Denominator[p], x]
(* RealQ *)
RealQ[z_] := SameQ[Head[z], Real]
(* RealValuedQ *)
RealValuedQ[z_] := NumberQ[z] && ZeroQ[Im[z]]
(* RemoveOptions *)
badOptionList = {}
goodOptionQ[ a_ -> b_ ] := ! MemberQ[badOptionList, a]
goodOptionQ[ a_ :> b_ ] := ! MemberQ[badOptionList, a]
goodOptionQ[ x_ ] := False
RemoveOptions[ oplist_List, badoplist_List ] :=
Block [ {},
badOptionList = badoplist;
Select[ oplist, goodOptionQ ] ]
(* ReplaceWith *)
SetAttributes[ReplaceWith, {Listable}]
ReplaceWith[org_, val_] := org -> val
(* RuleAppliesQ *)
(* Yes, I tried the "efficient" way of separating the lhs *)
(* and rhs to see if the lhs applies to an expression; *)
(* The would avoid the evaluation of the right-hand side. *)
(* The main problem is that we are not guaranteed to run *)
(* through all possible pattern matches since this separation *)
(* only considers one pattern match. Therefore, I had to *)
(* encode this by evaluating the rule using Replace. *)
RuleAppliesQ[expr_, rule_] := ! SameQ[expr, Replace[expr, rule]]
RuleAppliesQ[expr_, rule_, True] :=
Apply[ And, Map[ RuleAppliesQ[#, rule]&, Apply[List, expr] ] ]
(* SameFormQ *)
SameFormQ[form_, expr_] := MatchQ[expr, form]
SameFormQ[form_, expr1_, expr__] :=
SameFormQ[form, expr1] && SameFormQ[form, expr]
(* Second *)
Unprotect[Second]
Second[x_] := x[[2]]
Protect[Second]
(* SetExclusion *)
SetExclusion[sets__] := Complement[Union[sets], Intersection[sets]]
(* SetStateField *)
SetStateField[state_List, field_, value_] :=
Block [ {newstate},
newstate = state;
newstate[[field]] = value;
newstate ]
(* StripPackage *)
StripPackage[symbol_Symbol] := StripPackage[ ToString[symbol] ]
StripPackage[symbol_String] :=
Block [ {expandedstring, pos},
expandedstring = Characters[symbol];
pos = Position[expandedstring, "`"];
If [ SameQ[pos, {}],
symbol,
Apply[ StringJoin,
Drop[expandedstring, Last[Last[pos]]] ] ] ]
StripPackage[x_] := x
(* SubsetQ *)
SubsetQ[x1_] := True
SubsetQ[x1_, x2_] :=
Block [ {x1sorted},
x1sorted = Sort[x1];
SameQ[x1sorted, Intersection[x1sorted, x2]] ]
SubsetQ[x1_, x2_, x__] := SubsetQ[x1, x2] && SubsetQ[x2, x]
(* TableLookup *)
TableLookup[index_, table_, len_, val_] := (* multidimensional *)
Which [ TrueQ[ Apply[Or, Map[InfinityQ, index]] ],
val,
TrueQ[ InRange[1, index, len] ],
Apply[Part, {table} ~Join~ index],
True,
val ] /;
ListQ[index]
TableLookup[index_, table_, len_, val_] := (* one-dimensional *)
Which [ InfinityQ[index],
val,
TrueQ[ 1 <= index <= len ],
table[[index]],
True,
val ] /;
( InfinityQ[index] || IntegerQ[index] ) && IntegerQ[len]
(* Third *)
Third[x_] := x[[3]]
(* ToCollection *)
ToCollection[x_?AtomQ] := x
ToCollection[h_[args___]] := args
ToCollection[a__] := a
(* ToList *)
ToList[] := {}
ToList[arg_List] := arg
ToList[arg_] := List[arg] /; ! SameQ[Head[arg], List]
ToList[arg1_, args__] := List[arg1, args]
(* UnprotectIt *)
UnprotectIt[symbol_Symbol] :=
Block [ {attributes},
attributes = Attributes[Unprotect];
Unprotect[Unprotect];
ClearAttributes[Unprotect, {HoldFirst, HoldAll, HoldRest}];
Unprotect[symbol];
SetAttributes[Unprotect, attributes] ]
(* VariableQ *)
VariableQ[x_Symbol] := ! ConstantQ[x]
VariableQ[x_[n_Integer]] := HasAttributes[x, Constant]
VariableQ[x_] := False
(* ZeroQ *)
ZeroQ[x_] := SameQ[x, 0] || SameQ[x, 0.0]
(* ZPolynomial *)
ZPolynomial[m_Integer, n_] :=
(-1)^m Expand[ Product[n + k, {k, 0, m-1}] ] /; ( m > 0 )
(* E N D P A C K A G E *)
End[]
EndPackage[]
If [ TrueQ[ $VersionNumber >= 2.0 ],
On[ General::spell ];
On[ General::spell1 ];
On[ SetDelayed::write ];
On[ Set::write ];
On[ Set::wrsym ] ]
(* H E L P I N F O R M A T I O N *)
Block [ {newfuns},
newfuns =
{ AllSubsets, Assuming, CirclePS,
Combine, ComplexQ, ComplexTo2DCoord,
ComplexTo2DCoordList, ConstantQ, ConstantTerm,
Element, GenerateCode,
GenerateSymbol, GetAllExponents, GetAllFactors,
GetArgs, GetRoot, GetRootList,
GetShiftFactor, GetStateField, GetValue,
GetVariables, ImaginaryQ, InRange,
InfinityQ, InformUserQ,
ListQ, MixedPolynomialQ, MyApart,
MyCollectAll, MyFreeQ, MyMessage,
MyTogether, NegExponent, NormalizedQ,
PointwisePlot, PrintIt, RationalFunctionQ,
RationalPolynomialQ, RationalQ, RealQ,
RealValuedQ, RemoveOptions, ReplaceWith,
RuleAppliesQ, SameFormQ, Second,
SetExclusion, SetStateField, StripPackage,
SubsetQ, TableLookup, Third,
ToCollection, ToList, VariableQ,
ZeroQ, ZPolynomial };
SPfunctions = Combine[SPfunctions, newfuns];
Apply[Protect, newfuns];
Protect[Dialogue] ]
Protect[ SPSimplificationRules ]
(* E N D I N G M E S S A G E *)
If [ $notloaded, Print["Support module has been loaded."] ]
Remove[ $notloaded ]
These are the contents of the former NiCE NeXT User Group NeXTSTEP/OpenStep software archive, currently hosted by Netfuture.ch.