(* Useful functions for Mathematica. * Adam Dingle. *) 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 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[]