(* 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[]