9
$\begingroup$

Given list $L$ consisting only of $0$'s and $1$'s, we read $L$ backwards and construct a new list $O$ such that: (we start with $O=\{1\}$ and then apply the two rules:)

  • if we encounter $n$ consecutive $1$'s in $L$, we append $O$ to itself $n$ times

  • if we encounter $k$ consecutive $0$'s in $L$, we append $v$ consecutive $0$'s to the end of $O$, where $v$ is the sum of binary evaluations of the indices at which zeroes have been found.

For example $L=\{1,1,0,1,1,0,0,1,1\}$, we have in the output:

$$ O=((1_{4}0_{12})_{4}0_{64})_{4} $$

Where in $(x)_y$ indicates that element (sublist) $(x)$ is repeated $y$ times. Unpacking this notation actually gives:

O = {1, 1, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0}

How can I do this fast in Mathematica?

I'm using the output $O$'s as rows of huge matrices, so this function will be called up a lot.

My current function is working but I'm thinking we can be faster than this. Here it is: (second parameter cuts down or extends (with zeroes) the length of $O$)

gen[L_, ho_] := 
  Module[{last = 1, length = 0, j = 0, v = 0, O = {1}, h = 0}, 
   h = Min[2^Length[L], ho]; 
   Do[j = Length[L] - i; 
    If[L[[j]] == last && j != 0, length += 1, 
     If[last == 1, 
      Do[If[Length[O] >= h, Break[]]; 
       O = Join[O, O];, {t, 1, length}]; If[Length[O] >= h, Break[]];,
       v = Sum[2^k, {k, i - 1, i - length, -1}]; 
      O = Join[O, ConstantArray[0, Min[v, h - Length[O]]]]; 
      If[Length[O] >= h, Break[]];]; last = L[[j]]; length = 1;];, {i,
      0, Length[L]}]; Return[O[[;; Min[h, Length[O]]]]];];

gen[{1, 1, 0, 1, 1, 0, 0, 1, 1}, 512]
$\endgroup$
  • $\begingroup$ You can probably use Compile with very minor modifications to your code. Longer term you might want to use a less procedural algorithm, but to start out Compile would probably require less effort. $\endgroup$ – b3m2a1 Apr 8 at 19:53
  • $\begingroup$ Did you mean to write that when encountering "0", we should sum the indices or multiply them? I may be misreading your example, but going from right to left on L, I see two zeroes at positions 3 and 4 and the sum would be 7, giving the start of O as 7 rather than 12 zeroes. Wait. I think I understand. I should have summed binary {1,1,0} and {1,1,0,0}? Nope, still confused. $\endgroup$ – Mark R Apr 8 at 20:47
  • 1
    $\begingroup$ I think I finally have it. You mean 2^n where n is the position of the found zero. $\endgroup$ – Mark R Apr 8 at 20:53
5
$\begingroup$

Here is an even faster and less procedural method!

First, we'll define a function pack which will convert your list to the set of numbers {4, 12, 4, 64, 4} from your example - as you can see, it's enough to uniquely identify the resulting sequence:

pack[l_List] := Module[{counts = Length /@ Split[Reverse@l]},
  Riffle[
   2^(counts[[;; ;; 2]]), 
   (Rest[PolygonalNumber[counts]] *
    Most[2^Accumulate[counts]])[[;; ;; 2]]]]

It's pretty fast:

RepeatedTiming[pack[{1, 1, 0, 1, 1, 0, 0, 1, 1}]]
(* {0.0000120, {4, 12, 4, 64, 4}} *)

Next, we'll define a function to "unpack" this into an array of 0s and 1s:

join[l_, 1] := l
join[l_, n_] := Join[l, join[l, n - 1]] (* joins l with itself n times *)

unpack[{a_, b_, rest___}, start_] := 
 unpack[{rest}, Join[join[start, a], ConstantArray[0, b]]]
unpack[{a_}, start_] := join[start, a]

gen2[l_] := unpack[pack[l], {1}]

Now let's compare and time the results:

gen2[{1, 1, 0, 1, 1, 0, 0, 1, 1}] == 
  Elaborate[{1, 1, 0, 1, 1, 0, 0, 1, 1}] == 
  gen[{1, 1, 0, 1, 1, 0, 0, 1, 1}, 512]
(* True *)

First@RepeatedTiming[gen2[{1, 1, 0, 1, 1, 0, 0, 1, 1}]]
(* 0.0000264 *)

First@RepeatedTiming[Elaborate[{1, 1, 0, 1, 1, 0, 0, 1, 1}]]
(* 0.0000345 *)

First@RepeatedTiming[gen[{1, 1, 0, 1, 1, 0, 0, 1, 1}, 512]]
(* 0.000052 *)
| improve this answer | |
$\endgroup$
  • $\begingroup$ Btw, depending on your specific needs, you might not need to unpack the result right away, that's why I keep pack and unpack as two separate functions. $\endgroup$ – Victor K. Apr 8 at 23:29
3
$\begingroup$

I think this might work for you:

Elaborate[aList_List] := Block[
   {result, splitList, currentPosition},
   result = {1};
   currentPosition = 0;
   splitList = Split[Reverse@aList];
   (If[First[#] == 1,
       Nest[AppendTo[result, #] &, result, Length[#]];
       ,
       AppendTo[result, 
        Table[0, {Total[
           2^# & /@ 
            Range[currentPosition, currentPosition + Length[#] - 1]]}]]
       ];
      currentPosition += Length[#];
      ) & /@ splitList;
   Flatten[result]
   ];

If I set

input = {1, 1, 0, 1, 1, 0, 0, 1, 1};
Elaborate[input]

The result matches what you wrote.

Update with Timing:
I checked the timing and found the following:

RepeatedTiming[gen[{1, 1, 0, 1, 1, 0, 0, 1, 1}, 512]]
(* {0.000080,{...}} *)
RepeatedTiming[Elaborate[{1, 1, 0, 1, 1, 0, 0, 1, 1}]]
(* {0.0000523, {...}} *)

The method using a less procedural way is a little faster. Someone can probably think of how to speed up my code somewhat as well. There are different schools of thought on Parallelize, but that could be added if you don't have any concerns about it.

| improve this answer | |
$\endgroup$
  • 2
    $\begingroup$ Thinking about this, I don't think Parallelize may be added in any meaningful way since the results depend on processing in order. $\endgroup$ – Mark R Apr 8 at 22:08

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.