(* Useful functions for Mathematica.
* Adam Dingle. *)
(* edited by RJF 6/20/94 *)
(* Remove["Useful`*"]
Remove["Useful`Private`*"]
BeginPackage["Useful`"]
*)
AtPosition::usage =
"AtPosition[expr, p] returns the subexpression of expr which appears at
the position p, where p is of the form returned by Position."
CollectAssoc::usage =
"CollectAssoc[l], when l is a list of elements {e1, e2}, returns a list
of elements {e1, l}, where l is a list of elements which were paired with
e1 in the original list."
CollectSame::usage =
"CollectSame[l, f] returns a list of lists of elements of l which have
the same value under the function f."
CollectSame2::usage =
"CollectSame2[l, f] returns a list of elements {a, m}, where a is an
attribute and m is a list of elements of l with the attribute a."
Cons::usage =
"Cons is like Lisp's cons."
DeFun::usage =
"DeFun maps Function[x] to x."
EvalFun::usage =
"EvalFun[f] simplifies the given function by evaluating its interior."
FindFirst::usage =
"FindFirst[l, f] finds the first element of l for which f returns a non-Null
value v, and returns v."
Flatten1::usage =
"Flatten1[l] is equivalent to Flatten[l, 1]."
Fn = Function
HeldPosition::usage =
"HeldPosition[expr, p] returns the held subexpression of expr which appears
at the position p, where p is of the form returned by Position."
HoldApp::usage =
"HoldApp[Hold[a], Hold[b]] = Hold[a[b]]."
HoldEv::usage =
"HoldEv is like Hold, but evaluates its argument before holding it."
HoldList::usage = ""
Index::usage =
"Index[list, element] gives the position at which the element appears
in the list, or Null if it is not a member of the list."
InverseAt::usage =
"InverseAt[f, x] returns the inverse function for f that is appropriate at
the point x, i.e. for which f_inv[f[x]] = x."
Inverses::usage =
"Inverses[f] returns a list of inverse functions for f (using Solve)."
IsConstant::usage =
"IsConstant[a] returns true if a is manifestly a number of any kind."
IsReal::usage =
"IsReal[a] returns true if a is manifestly a real number of any kind."
Let = With
(* Lets is like let* in common lisp. sequential version of Let. rather
than the parallel version in Mathematica [= With]. RJF 6/23/94 *)
SetAttributes[{Lets},HoldAll]
Lets[{a_},s_]:=With[{a},s]
Lets[{a_,r__},s_]:=With[{a},Lets[{r},s]]
(* example
In[26]:= Lets[{a={Print[{a,b,c}];1},
b={Print[{a,b,c}];2},
c={Print[{a,b,c}];3}},
{a,b,c}]
{a, b, c}
{{1}, b, c}
{{1}, {2}, c}
Out[26]= {{1}, {2}, {3}}
*)
Lookup::usage =
"Lookup[e, l] looks up the element e in the association list l, returning
Null if it is not found."
ls::usage = "Gives a list of symbols in the current context."
ls := Names[$Context <> "*"]
MapAtR::usage =
"MapAtR[expr, pos, f] is equivalent to MapAt[f, expr, pos]."
MapL::usage =
"MapL[expr, f] is equivalent to Flatten1[Map[f, expr]]."
MapR::usage =
"MapR[expr, f] is equivalent to Map[f, expr]."
MapList::usage =
"MapList[f, a] maps f onto each element of a if a is a list; otherwise it
applies f to a itself."
NLess::usage =
"NLess is like Less, but uses N to compare its arguments."
NullQ::usage =
"NullQ returns true if its argument is null."
rm = Remove
Select1::usage =
"Select1[list, crit] selects the first element in the list which satisfies the
given criterion, or Null if no element satifies the criterion."
SMap::usage =
"SMap[f, s] maps f onto the syntactic form s. f will be
applied to the Hold of each component of the syntactic form; f should return
the Hold of a syntactic result."
SMapAt::usage =
"SMapAt[f, s, p] maps f onto the syntactic form s at position p. f will be
applied to the Hold of the syntactic component at that position; f should
return the Hold of a syntactic result."
SMapAtList::usage =
"SMapAtList[f, s, l] maps f onto the syntactic form s at each position in the
list l."
SortR::usage =
"SortR[p, list] is equivalent to Sort[list, p]."
PrintWith::usage =
"PrintWith is useful as an argument to the TraceScan[] function. When given
a With[] expression, it will print out the value to which the variable in the
With[] is assigned."
TraceWith::usage =
"TraceWith[e] will trace all With[] assignments in the evaluation of the
given expression."
Squish::usage =
"Squish[f, l] combines adjacent elements of l using the function f, which is
invoked on each pair of adjacent elements."
(* Begin["`Private`"]*)
AtPosition[expr_, p_] := Apply[Part, Prepend[p, expr]]
EvalFun[Fn[f_]] := Fn[Evaluate[f]] (* convert to canonical form *)
EvalFun[Sqrt] := EvalFun[Sqrt[#] &] (* convert to power form *)
EvalFun[f_] := f
HeldPosition[expr_, p_] := Apply[HeldPart, Prepend[p, expr]]
HoldApp[Hold[a_], Hold[b_]] := Hold[a[b]]
HoldEv[a_] := Hold[a]
(* Is it possible to do this non-recursively (i.e. using map or something
* like that?) *)
HoldList2[{}, h_] := h
HoldList2[{Hold[a_], b___}, Hold[h___]] := HoldList2[{b}, Hold[h, a]]
HoldList[l_] := HoldList2[l, Hold[]]
Index[l_, e_] := Position[l, e, 1, 1][[1, 1]]
InverseAt[f_, x_] := Select1[MyInverse[f], #[f[x]] == x&]
(* old code
Inverses[# ^ r_Rational &] :=
{Fn[Evaluate[
If[-2 Pi r < Arg[#] < 2 Pi r,
Evaluate[#^(1/r)], Null]]]} /; Numerator[r] == 1
*)
FixInvPower[g_] :=
(* Look for an InverseFunction of InvPower that Solve may have returned;
* if so, prefix the entire function with an If representing the condition
* under which the inverse power exists. We currently can't handle more
* than one inverse power in an expression (but to do so, we would probably
* only need to construct the conjunction of the conditions).
* Could probably be implemented more elegantly - "InverseFunction" appears
* 3 times. *)
Let[{p = Position[g, InverseFunction[InvPower, 1, 2][_, _]]},
Switch[Length[p],
0, g,
1, Fn[Evaluate[Replace[AtPosition[g, p[[1]]],
InverseFunction[InvPower, 1, 2][e_, r_] :>
(* always matches *)
If[- Pi r < Arg[e] && Arg[e] <= Pi r,
Evaluate[DeFun[g] /.
InverseFunction[InvPower, ___][_, _] :> e^(1/r)],
Null]]]],
2, Abort[]]]
Inverses[f_] :=
Let[{fp = f /. (e_ ^ r_Rational /; (Numerator[r] == 1)) -> InvPower[e, r]},
(Off[Solve::ifun];
Let[{i = Module[{s}, Fn[b, b&] /@ (s /. Simplify[Solve[fp[s] == #, s]])]},
(On[Solve::ifun];
MapR[i, FixInvPower])])]
(* old code
EvalFun[g /. InverseFunction[InvPower, 1, 2][e_, r_] :>
If[- Pi r < Arg[e] && Arg[e] <= Pi r, Evaluate[e^(1/r)], Null]]
*)
Flatten1[l_] := Flatten[l, 1]
Lookup[e_, l_] :=
Let[{p = Select1[l, Fn[i, i[[1]] === e]]},
If[NullQ[p], Null, p[[2]]]]
MapL[expr_, f_] := Flatten1[Map[f, expr]]
MapList[f_, a_] := If[ListQ[a], Map[f, a], f[a]]
MapR[expr_, f_] := Map[f, expr]
MapAtR[expr_, pos_, f_] := MapAt[f, expr, pos]
NLess[a_, b_] := N[a < b]
NullQ[Null] := True
NullQ[___] := False
Select1[list_, crit_] :=
Let[{l = Select[list, crit, 1]},
If[l === {}, Null, l[[1]] ]]
SMap[f_, a_] := Apply[Head[a], HoldList[Map[f, Apply[List, Map[Hold, a]]]]]
SMapAt[f_, a_, p_] := ReplaceHeldPart[a, f[HeldPosition[a, p]], p]
SMapAtList[f_, a_, l_] := Fold[SMapAt[f, #1, #2]&, a, l]
SortR[p_, list_] := Sort[list, p]
ClearAttributes[If, HoldAll]
SetAttributes[If, HoldRest]
PrintWith[HoldForm[With[{var_ = exp_}, _]]] := Print[var->exp]
TraceWith[e_, opt___] := TraceScan[PrintWith, e, With[___], opt]
Attributes[TraceWith] = {HoldAll}
CollectSame2[l_, f_] :=
(* Given: list, function which computes attribute for each list element
* Return: list of {attribute, list of elements with attribute}
* QUADRATIC IMPLEMENTATION *)
Let[{d = Union[MapR[l, f]]},
MapR[d, Fn[a, (* for each attribute *)
(* select elements with that attribute *)
{a, Select[l, Fn[e, f[e] === a]]}
]]]
CollectSame[l_, f_] := MapR[CollectSame2[l, f], Fn[n, n[[2]]]]
Cons[a_, b_] := Prepend[b, a]
Squish[f_, {a_, b_, c___}] :=
Let[{d = f[a, b]},
If[d === {}, Cons[a, Squish[f, {b, c}]],
Squish[f, {d, c}]]]
Squish[_, a_] := a
IsConstant[a_] := NumberQ[N[a]]
IsReal[a_] := Let[{n = N[a]}, NumberQ[n] && Im[n] == 0]
DeFun[Function[x_]] := x
DeFun[Identity] := #
(* End[]
EndPackage[] *)