Added in Edit: Let's decide to do exactly what the OP says: produce a functor that takes a list, processes it, and returns a Listable
function taking floating point numbers to indices. What we really want to do is construct and return something like
If[# >= 7.95001, 4 + If[# >= 8.6823,1,0],
If[# >= 4.56535, 2 + If[# >= 7.04274,1,0], If[# >= 0.405196,1,0]]] &
when handed the example list of the Question. This should be easy enough by composing partially specialized If[-,-,-]
functions recursively down to the leaves of the binary search expression tree.
You might think something like this would work
Clear[findIndices];
findIndices[S_] := Module[{
binSearch, f, x},
binSearch[{}] :> 0;
binSearch[s_List /; Length[s] == 1] :> If[x >= s[[1]], 1, 0];
binSearch[s_List /; Length[s] > 1] :> Module[{
po2, lower, upper},
po2 = 2^Floor[Log[2, Length[s]]];
lower = Take[s, po2 - 1];
upper = Take[s, {po2 + 1, -1}];
If[x >= s[[po2]], po2 + binSearch[Evaluate[upper]],
binSearch[Evaluate[lower]]]
];
f = Function[x,
Evaluate[
FixedPoint[
Evaluate,
binSearch[S]
]
]
];
SetAttributes[f, Listable];
f
]
But the utterly inscrutable evaluation rules ensure that you can never actually evaluate a recursive function except when doing so is a mistake. (I would like to say this is humour, but it is not.)
Added in Edit: (We do eventually overcome Mathematica's unintelligible evaluation by circumventing it entirely. This was present in the original answer and appears below this long trek through M'ma's failure to be a functional programming tool.) What do I mean by "except when doing so is a mistake"? Forget to put in your base case for a recursion:
Clear[f]
f[n_] = f[n - 1]
(* $IterationLimit::itlim: Iteration limit of 4096 exceeded. >> *)
(* Hold[f[-1 + (-4095 + n)]] *)
Mathematica is quite ready to evaluate that recursive expansion. Now let's compare that behaviour with the semantics of the above code. We have a bunch of delayed rules for binSearch
expressions (and the relevant base cases are present). We repeatedly Evaluate
binSearch[S]
and the resulting expressions in the vain hope that this will result in recursive expansion of binSearch
. Let's replace f = ...
with
Print[binSearch[S]];
Print[Evaluate[binSearch[S]]];
Then follow the modified findIndices
with
findIndices[S]
(* binSearch$59538[{0.405196,4.56535,7.04274,7.95001,8.6823}] *)
(* binSearch$59538[{0.405196,4.56535,7.04274,7.95001,8.6823}] *)
so those delayed rules don't do anything and Evaluate
doesn't seem to evaluate anything. Let's try assignments (Some of the following variants appear, possibly spliced with other variants, in the first edit to this post.)
Clear[findIndices];
findIndices[S_] := Module[
{binSearch, f, x}, binSearch[{}] = 0;
binSearch[s_List /; Length[s] == 1] = If[x >= s[[1]], 1, 0];
binSearch[s_List /; Length[s] > 1] =
Module[{po2, lower, upper}, po2 = 2^Floor[Log[2, Length[s]]];
lower = Take[s, po2 - 1];
upper = Take[s, {po2 + 1, -1}];
If[x >= s[[po2]], po2 + binSearch[Evaluate[upper]],
binSearch[Evaluate[lower]]]];
Print[binSearch[S]];
Print[Evaluate[binSearch[S]]];
]
findIndices[S]
(* Part::partd: Part specification s$[[1]] is longer than depth of object. >> *)
(* ... *)
Unsurprisingly, the immediate evaluation of the RHSs of the Set
s fails. SetDelayed
?
Clear[findIndices];
findIndices[S_] := Module[
{binSearch, f, x}, binSearch[{}] := 0;
binSearch[s_List /; Length[s] == 1] := If[x >= s[[1]], 1, 0];
binSearch[s_List /; Length[s] > 1] :=
Module[{po2, lower, upper}, po2 = 2^Floor[Log[2, Length[s]]];
lower = Take[s, po2 - 1];
upper = Take[s, {po2 + 1, -1}];
If[x >= s[[po2]], po2 + binSearch[Evaluate[upper]],
binSearch[Evaluate[lower]]]];
Print[binSearch[S]];
Print[Evaluate[binSearch[S]]];
]
findIndices[S]
(* If[x$61633 >= 7.95001, po2$61634 + binSearch$61633[Evaluate[upper$61634]], binSearch$61633[Evaluate[lower$61634]]] *)
(* If[x$61633 >= 7.95001, po2$61635 + binSearch$61633[Evaluate[upper$61635]], binSearch$61633[Evaluate[lower$61635]]] *)
Well, that's somewhat better. binSearch
is expanded exactly once, but the variable binding in the inner Module
is ignored so that the result references the Global
ly unresolvable names po2
, binSearch
, upper
, and lower
.
Well hmm... Relying on function expansion is a non-starter. Maybe we can get this by rewriting the root expression binSearch[S]
, ReplaceRepeated
ing until the result stops changing...
Clear[findIndices];
findIndices[S_] := Module[
{binSearch, f, x},
f = binSearch[S] //. {
binSearch[{}] :> 0,
binSearch[s_List /; Length[s] == 1] :> If[x >= s[[1]], 1, 0],
binSearch[s_List /; Length[s] > 1] :>
Module[{po2, lower, upper}, po2 = 2^Floor[Log[2, Length[s]]];
lower = Take[s, po2 - 1];
upper = Take[s, {po2 + 1, -1}];
If[x >= s[[po2]], po2 + binSearch[Evaluate[upper]],
binSearch[Evaluate[lower]]]]
};
Print[f];
Print[Evaluate[f]];
]
findIndices[S]
(* If[x$61671 >= 7.95001, po2$61672 + binSearch$61671[Evaluate[upper$61672]], binSearch$61671[Evaluate[lower$61672]]] *)
(* If[x$61671 >= 7.95001, po2$61672 + binSearch$61671[Evaluate[upper$61672]], binSearch$61671[Evaluate[lower$61672]]] *)
... so apparently RuleDelayed
and Module
have the option to not bother doing any of that variable binding they're documented to do. Let's force that binding to be a little more prompt with With
... and we have to nest With
s since the second and third local depend on the value of the first local ...
Clear[findIndices];
findIndices[S_] := Module[
{binSearch, f, x},
f = binSearch[S] //. {
binSearch[{}] :> 0,
binSearch[s_List /; Length[s] == 1] :> If[x >= s[[1]], 1, 0],
binSearch[s_List /; Length[s] > 1] :>
With[{po2 = 2^Floor[Log[2, Length[s]]]},
With[{lower = Take[s, po2 - 1],
upper = Take[s, {po2 + 1, -1}]},
If[x >= s[[po2]], po2 + binSearch[Evaluate[upper]],
binSearch[Evaluate[lower]]]
]]
};
Print[f];
Print[Evaluate[f]];
]
findIndices[S]
(* If[x$62332 >= 7.95001, 4 + binSearch$62332[Evaluate[{8.6823}]], binSearch$62332[Evaluate[{0.405196, 4.56535, 7.04274}]]] *)
(* If[x$62332 >= 7.95001, 4 + binSearch$62332[Evaluate[{8.6823}]], binSearch$62332[Evaluate[{0.405196, 4.56535, 7.04274}]]] *)
... slightly better. At least With
can do Module
's job for it and we get evaluated copies of upper
and lower
, but not evaluated enough. Perhaps strip the Evaluate
s?
Clear[findIndices];
findIndices[S_] := Module[
{binSearch, f, x},
f = binSearch[S] //. {
binSearch[{}] :> 0,
binSearch[s_List /; Length[s] == 1] :> If[x >= s[[1]], 1, 0],
binSearch[s_List /; Length[s] > 1] :>
With[{po2 = 2^Floor[Log[2, Length[s]]]},
With[{lower = Take[s, po2 - 1],
upper = Take[s, {po2 + 1, -1}]},
If[x >= s[[po2]], po2 + binSearch[upper], binSearch[lower]]
]]
};
Print[f];
Print[Evaluate[f]];
]
findIndices[S]
(* If[x$62345 >= 7.95001, 4 + If[x$62345 >= {8.6823}[[1]], 1, 0],
With[{po2$ = 2^Floor[Log[2, Length[{0.405196, 4.56535, 7.04274}]]]},
With[{lower$ = Take[{0.405196, 4.56535, 7.04274}, po2$ - 1],
upper$ = Take[{0.405196, 4.56535, 7.04274}, {po2$ + 1, -1}]},
If[x$62345 >= {0.405196, 4.56535, 7.04274}[[po2$]],
po2$ + binSearch$62345[upper$], binSearch$62345[lower$]]]]] *) (* If[x$62345 >= 7.95001, 4 + If[x$62345 >= {8.6823}[[1]], 1, 0],
With[{po2$ = 2^Floor[Log[2, Length[{0.405196, 4.56535, 7.04274}]]]},
With[{lower$ = Take[{0.405196, 4.56535, 7.04274}, po2$ - 1],
upper$ = Take[{0.405196, 4.56535, 7.04274}, {po2$ + 1, -1}]},
If[x$62345 >= {0.405196, 4.56535, 7.04274}[[po2$]],
po2$ + binSearch$62345[upper$], binSearch$62345[lower$]]]]] *)
so With
isn't actually binding any values. Maybe we can help it out by not using locals...
Clear[findIndices];
findIndices[S_] := Module[
{binSearch, f, x},
f = binSearch[S] //. {
binSearch[{}] :> 0,
binSearch[s_List /; Length[s] == 1] :> If[x >= s[[1]], 1, 0],
binSearch[s_List /; Length[s] > 1] :>
With[{po2 = 2^Floor[Log[2, Length[s]]]},
If[x >= s[[po2]], po2 + binSearch[Take[s, {po2 + 1, -1}]],
binSearch[Take[s, po2 - 1]]]
]
};
Print[f];
Print[Evaluate[f]];
]
findIndices[S]
(* If[x$62362 >= 7.95001, 4 + binSearch$62362[Take[{0.405196, 4.56535, 7.04274, 7.95001, 8.6823}, {4 + 1, -1}]], binSearch$62362[Take[{0.405196, 4.56535, 7.04274, 7.95001, 8.6823}, 4-1]]] *)
(* If[x$62362 >= 7.95001, 4 + binSearch$62362[Take[{0.405196, 4.56535, 7.04274, 7.95001, 8.6823}, {4 + 1, -1}]], binSearch$62362[Take[{0.405196, 4.56535, 7.04274, 7.95001, 8.6823}, 4-1]]] *)
... so now With
has changed its mind and actually binds po2
to a value. Mysterious. However, there's no change in expanding the once nested calls to binSearch
; they're still unexpanded. Why? Because the head of Take[...]
is not List
. So why has po2
been evaluated in place, but 4-1
, Take[...]
, et al, not? Beats me. Let's try telling them to be evaluated.
Clear[findIndices];
findIndices[S_] := Module[
{binSearch, f, x},
f = binSearch[S] //. {
binSearch[{}] :> 0,
binSearch[s_List /; Length[s] == 1] :> If[x >= s[[1]], 1, 0],
binSearch[s_List /; Length[s] > 1] :>
With[{po2 = 2^Floor[Log[2, Length[s]]]},
If[x >= s[[po2]],
po2 + binSearch[Evaluate[Take[s, {po2 + 1, -1}]]],
binSearch[Evaluate[Take[s, po2 - 1]]]]
]
};
Print[f];
Print[Evaluate[f]];
]
findIndices[S]
(* If[x$62371 >= 7.95001, 4 + binSearch$62371[Evaluate[Take[{0.405196, 4.56535, 7.04274, 7.95001, 8.6823}, {4+1, -1}]]], binSearch$62371[Evaluate[Take[{0.405196, 4.56535, 7.04274, 7.95001, 8.6823}, 4-1]]]] *)
(* If[x$62371 >= 7.95001, 4 + binSearch$62371[Evaluate[Take[{0.405196, 4.56535, 7.04274, 7.95001, 8.6823}, {4+1, -1}]]], binSearch$62371[Evaluate[Take[{0.405196, 4.56535, 7.04274, 7.95001, 8.6823}, 4-1]]]] *)
That certainly made the result longer. Didn't evaluate anything, though. Maybe we should catch that non-List
head and force it to evaluate.
Clear[findIndices];
findIndices[S_] := Module[
{binSearch, f, x},
f = binSearch[S] //. {
binSearch[{}] :> 0,
binSearch[s_List /; Length[s] == 1] :> If[x >= s[[1]], 1, 0],
binSearch[s_List /; Length[s] > 1] :>
With[{po2 = 2^Floor[Log[2, Length[s]]]},
If[x >= s[[po2]], po2 + binSearch[Take[s, {po2 + 1, -1}]],
binSearch[Take[s, po2 - 1]]]
],
binSearch[other_ /; Head[other] =!= List] :>
(Print["Hi."]; binSearch[Evaluate[other]])
};
Print[f];
Print[Evaluate[f]];
]
findIndices[S]
(* If[x$543 >= 7.95001, 4 + binSearch$543[Take[{0.405196, 4.56535, 7.04274, 7.95001, 8.6823},{4+1, -1}]], binSearch$543[Take[{0.405196, 4.56535, 7.04274, 7.95001, 8.6823}, 4-1]]] *)
(* If[x$543 >= 7.95001, 4 + binSearch$543[Take[{0.405196, 4.56535, 7.04274, 7.95001, 8.6823},{4+1, -1}]], binSearch$543[Take[{0.405196, 4.56535, 7.04274, 7.95001, 8.6823}, 4-1]]] *)
Our rule for non-List
heads was never called (because it would have printed "Hi." if it had). So the problem is not that we have a non-List
head. Although we have a non-List
head. I wonder which of the implicit and poorly documented evaluation rules is causing the Take
s to not be Take
s except when they are.
Notice: At no time did our semantics change: Recursively evaluate to the leaves. We're told Mathematica is talented at repeated string rewriting and recursive function expansion. But apparently not.
Maybe if we could have set binSearch
to have attribute EvaluateAll
(if that were a thing) the Kernel's randomly applied evaluation and variable binding would have actually done what we said we wanted.
And here's where I quit pretending the language is capable of functional programming. The functional programming fails because we have no control over when those Take
s evaluate. The only way to proceed is to be precisely non-functional: hide the functions wrapping the Take
s from Mathematica in strings, then re-interpret the strings as expressions after the recursion completes. This is the stupidest possible thing to have to do. The cognitive load in guessing which apply of several nested "this evaluates except ..."s is unworkable.
Even if someone manages to make some variant of this work, I'm not interested. The semantics were straightforward. The evaluation was borked by the Kernel at every step.
It would seem the only way to overcome Mathematica's psychic ability to engage in recursion only when you don't want it is to circumvent the evaluation rules by constructing string expressions, so you can actually control evaluation.
Clear[binSearch];
binSearch["{}"] = "0";
binSearch[s_String /; Length[ToExpression[s]] == 1] :=
"If[#>=" <> ToString[ToExpression[s][[1]]] <> ",1,0]";
binSearch[s_String] := Module[{
sexpr, po2, lower, upper},
sexpr = ToExpression[s];
po2 = 2^Floor[Log[2, Length[sexpr]]];
lower = Take[sexpr, po2 - 1];
upper = Take[sexpr, {po2 + 1, -1}];
"If[#>=" <> ToString[sexpr[[po2]]] <> "," <> ToString[po2] <>
" + " <> binSearch[ToString[upper]] <> "," <>
binSearch[ToString[lower]] <> "]"
]
Clear[findIndices];
findIndices[S_] := Module[{
f, x},
f = Function[Evaluate[ToExpression[binSearch[ToString[S]]]]];
(* SetAttributes[f, Listable]; *) (* Don't bother. Does nothing. *)
f
]
Note the comment about SetAttributes
. Nothing you can set in here will cause the f
in the Global
namespace to be Listable
, not even explicitly making it so in the Global
namespace.
Clear[f]
f = findIndices[S];
SetAttributes[f, Listable]
f
(* If[#1 >= 7.95001, 4 + If[#1 >= 8.6823, 1, 0],
If[#1 >= 4.56535, 2 + If[#1 >= 7.04274, 1, 0],
If[#1 >= 0.405196, 1, 0]]] & *)
f /@ {1.1, 5.1, 9.1}
(* {1, 2, 5) *)
What do I mean setting Listable
does nothing?
f[{1.1, 5.1, 9.1}]
(* If[{1.1, 5.1, 9.1} >= 7.95001,
4 + If[{1.1, 5.1, 9.1} >= 8.6823, 1, 0], If[{1.1, 5.1, 9.1} >= 4.56535,
2 + If[{1.1, 5.1, 9.1} >= 7.04274, 1, 0], If[{1.1, 5.1, 9.1} >= 0.405196, 1, 0]]] *)
(sigh) What I wouldn't give for a Mathematica that wasn't an impediment to functional programming...
Oh, right. Timing.
tst = RandomReal[{0.5, 10}, 10^6];
f /@ tst; // AbsoluteTiming
(* {0.172239, Null} *)
I imagine it would be a little faster Compile
d, but I'm done fighting with this language for a few days.
Edit: 20170910T0429Z
Compilation makes it about 25-times slower.
Clear[cf];
cf = Compile[{{x, _Real}}, f[x]]
cf /@ tst; // AbsoluteTiming
(* {4.37982, Null} *)
As for f
, setting cf
listable does nothing, so I don't waste space on it.
It's worth pointing out that all of the Compile
d versions here risk erroneous output due to precision loss. Test values exceedingly close to but greater than a separating value can compare equal to the separating value when coerced to _Real
, so will be reported in the bin one less than their actual bin.
Since I get the impression Mr. Wizard is unable to generate his own demonastrations of inscrutable evaluation fails...
Clear[findIndices];
findIndices[S_] := Module[{binSearch, f, x},
binSearch[{}] := 0;
binSearch[s_List /; Length[s] == 1] := If[x >= s[[1]], 1, 0];
binSearch[s_List /; Length[s] > 1] :=
Module[{po2, lower, upper}, po2 = 2^Floor[Log[2, Length[s]]];
lower = Take[s, po2 - 1];
upper = Take[s, {po2 + 1, -1}];
If[x >= s[[po2]], po2 + binSearch[Evaluate[upper]],
binSearch[Evaluate[lower]]]];
Print[binSearch[S]];
f = Function[x, Evaluate[FixedPoint[Evaluate, binSearch[S]]]];
SetAttributes[f, Listable];
f
]
f = findIndices[S]
(* If[x$1452 >= 7.95001, po2$1453 + binSearch$1452[Evaluate[upper$1453]],
binSearch$1452[Evaluate[lower$1453]]] *)
(* Function[x$,
If[x$1452 >= 7.95001, po2$1454 + binSearch$1452[Evaluate[upper$1454]],
binSearch$1452[Evaluate[lower$1454]]]] *)
Clear[findIndices];
findIndices[S_] := Module[{binSearch, f, x},
f = Function[x, binSearch[S]] //. {
binSearch[{}] :> 0,
binSearch[s_List /; Length[s] == 1] :> If[x >= s[[1]], 1, 0],
binSearch[s_List /; Length[s] > 1] :>
Module[{po2, lower, upper}, po2 = 2^Floor[Log[2, Length[s]]];
lower = Take[s, po2 - 1];
upper = Take[s, {po2 + 1, -1}];
If[x >= s[[po2]], po2 + binSearch[Evaluate[upper]],
binSearch[Evaluate[lower]]]]
};
SetAttributes[f, Listable];
f
]
f = findIndices[S]
(* Function[x$, Module[{po2$, lower$, upper$},
po2$ = 2^Floor[Log[2, Length[{0.405196, 4.56535, 7.04274, 7.95001, 8.6823}]]];
lower$ = Take[{0.405196, 4.56535, 7.04274, 7.95001, 8.6823}, po2$ - 1];
upper$ = Take[{0.405196, 4.56535, 7.04274, 7.95001, 8.6823}, {po2$ + 1, -1}];
If[x$1792 >= {0.405196, 4.56535, 7.04274, 7.95001, 8.6823}[[po2$]],
po2$ + binSearch$1792[Evaluate[upper$]], binSearch$1792[Evaluate[lower$]]]]] *)
Clear[findIndices];
findIndices[S_] := Module[{binSearch, f, x},
f = Function[x, binSearch[S]] //. {
binSearch[{}] :> 0,
binSearch[s_List /; Length[s] == 1] :> If[x >= s[[1]], 1, 0],
binSearch[s_List /; Length[s] > 1] :> Module[{po2},
po2 = 2^Floor[Log[2, Length[s]]];
If[x >= s[[po2]],
po2 + binSearch[Evaluate[Take[s, {po2 + 1, -1}]]],
binSearch[Evaluate[Take[s, po2 - 1]]]]]
};
SetAttributes[f, Listable];
f
]
f = findIndices[S]
(* Function[x$,
Module[{po2$}, po2$ = 2^Floor[
Log[2, Length[{0.405196, 4.56535, 7.04274, 7.95001, 8.6823}]]];
If[x$2307 >= {0.405196, 4.56535, 7.04274, 7.95001, 8.6823}[[po2$]],
po2$ + binSearch$2307[Evaluate[Take[{0.405196, 4.56535,
7.04274, 7.95001, 8.6823}, {po2$ + 1, -1}]]], binSearch$2307[
Evaluate[Take[{0.405196, 4.56535, 7.04274, 7.95001, 8.6823}, po2$ - 1]]]]]] *)
Clear[findIndices];
findIndices[S_] := Module[{binSearch, f, x}, binSearch[{}] := 0;
binSearch[s_List /; Length[s] == 1] := If[# >= s[[1]], 1, 0];
binSearch[s_List /; Length[s] > 1] :=
With[{po2 = 2^Floor[Log[2, Length[s]]]},
With[{lower = Take[s, po2 - 1],
upper = Take[s, {po2 + 1, -1}]},
If[# >= s[[po2]], po2 + binSearch[upper], binSearch[lower]]]];
binSearch[other_] := binSearch[Evaluate[other]];
Print[binSearch[S]];
f = Function[Evaluate[FixedPoint[Evaluate, binSearch[S]]]];
SetAttributes[f, Listable];
f]
f = findIndices[S]
(* If[#1 >= 7.95001, 4 + binSearch$2384[{8.6823}],
binSearch$2384[{0.405196,4.56535, 7.04274}]] *)
(* If[#1 >= 7.95001, 4 + binSearch$2384[{8.6823}],
binSearch$2384[{0.405196, 4.56535, 7.04274}]]] & *)
GeometricFunctions`BinarySearch[S, #] & /@ list1
almost does what you want. $\endgroup$BinarySearch
really use binary search? Because the running time seems to increase linearly with the length of the list?? $\endgroup$