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]
Improve this question
$\endgroup$
3
  • $\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$ Commented Apr 8, 2020 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$ Commented Apr 8, 2020 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$ Commented Apr 8, 2020 at 20:53

2 Answers 2

Reset to default
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$
1
  • $\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$ Commented Apr 8, 2020 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$
1
  • 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$ Commented Apr 8, 2020 at 22:08

Start asking to get answers

Find the answer to your question by asking.

Ask question

Explore related questions

See similar questions with these tags.