16
$\begingroup$

How would I construct a function that outputs Dyck Words?

e.g. - there are 14 words in $\mathcal{D}_{8}$:

`[[[[]]]], [[[][]]], [[[]][]], [[][[]]], [[[]]][], [[][][]], [][[[]]], 
 [[][]][], [[]][[]], [][[][]], [[]][][], [][[]][], [][][[]], [][][][]`

There is an equivalent question here, but the answer only gives information about the number of cases.

I was playing around with things like

nest[n_] := 
DeleteCases[Quiet[ToExpression /@ (StringReplace[#, "}{" -> "},{"] & /@ 
StringJoin /@ Permutations[Flatten@Array[{"{", "}"} &, n], {2 n}])], $Failed]

... will keep at it!

$\endgroup$
4
$\begingroup$

Here is another compiled implementation for generating Dyck words in lexicographic order, this time using Knuth's "Algorithm P":

dyckBits = Compile[{{n, _Integer}},
                   Module[{c, db, f, j, k, m, s, t, v, w, bitEncInts},
                          m = n - 1; c = t = 2^m; s = Quotient[8 c - 1, 3];
                          db = Internal`Bag[Most[{1}]];
                          While[True, Internal`StuffBag[db, s];
                                s = BitOr[s, c]; f = Quotient[c, 2];
                                If[BitAnd[Quotient[s, f], 1] == 1,
                                   m--; c = f;
                                   s = BitAnd[s, BitNot[c]],
                                   j = m - 1; k = n - 1; v = f; w = t;
                                   While[BitAnd[Quotient[s, v], 1] == 0,
                                         s = BitOr[BitAnd[s, BitNot[w]], v];
                                         j--; k -= 2;
                                         v = Quotient[v, 2]; w = Quotient[w, 4]];
                                   If[j == 0, Break[]];
                                   s = BitAnd[s, BitNot[v]];
                                   m = n - 1; c = t]];
                          bitEncInts = Quotient[Internal`BagPart[db, All], 2];
                          IntegerDigits[#, 2, n] & /@ bitEncInts],
                   RuntimeOptions -> "Speed"];

(* thanks to Jacob Akkerboom *)
ccConv = Compile[{{dyckBits, _Integer, 2}}, Subtract[93, 2 dyckBits],
                 RuntimeOptions -> "Speed"];

dyckWordsCc[n_Integer?EvenQ] := FromCharacterCode[ccConv[dyckBits[n]]]

The choice to use bits to represent the Dyck words lends itself well to using compilation, so I've found this to be much faster than the routine in my other post.

dyckWordsCc[8]
   {"[][][][]", "[[]][][]", "[][[]][]", "[[][]][]", "[[[]]][]", "[][][[]]", "[[]][[]]",
    "[][[][]]", "[[][][]]", "[[[]][]]", "[][[[]]]", "[[][[]]]", "[[[][]]]", "[[[[]]]]"}

For reference, here's the version of "Algorithm P" that directly works with strings:

dyckStrings[n_Integer?EvenQ] := Module[{j, k, m, s},
            m = n; s = StringJoin[Prepend[ConstantArray["[]", n/2], "]"]];
            Reap[While[True, Sow[StringDrop[s, 1]];
                       s = StringReplacePart[s, "]", {m, m}];
                       If[StringPart[s, m - 1] === "]",
                          m--; s = StringReplacePart[s, "[", {m, m}],
                          j = m - 1; k = n;
                          While[StringPart[s, j] === "[",
                                s = StringReplacePart[s, {"[", "]"}, {{k, k}, {j, j}}];
                                j--; k -= 2];
                          If[j == 1, Break[]];
                          s = StringReplacePart[s, "[", {j, j}]; m = n]]
                 ][[-1, 1]]]

It is quite a bit slower.

| improve this answer | |
$\endgroup$
  • $\begingroup$ Hey J.M., I made a mn adaptation of your answer. It appears there was a different way to do the post processing that was more efficient. $\endgroup$ – Jacob Akkerboom Mar 30 '17 at 10:20
  • $\begingroup$ I felt it was best to merge my adaptation into your answer. I renamed the function dyckWordsCc, where Cc stands for CharacterCode. I think all this makes it easier to compare timings. I also think this makes it easier for somebody who just wants to copy paste some nice code to find the right definition. $\endgroup$ – Jacob Akkerboom Mar 30 '17 at 13:08
  • $\begingroup$ @Jacob, I'm OK with it. $\endgroup$ – J. M.'s discontentment Mar 30 '17 at 13:10
  • $\begingroup$ This is fast! But it also uses an order of magnitude more memory than my recursion does. Can that be improved? $\endgroup$ – Mr.Wizard Mar 31 '17 at 7:47
  • 1
    $\begingroup$ @J.M. It seems that your original version used less memory (twice as much as Mr. W's. Mr.W's is essentially the output ByteCount). In particular the original dyckBits is quite efficient. It seems most memory is used in the ccConv step. Compiling ccConv was contraproductive, things are both faster and more memory efficient if we do not do this. I'm pretty sure a LibraryLink solution for ccConv would use considerably less memory. $\endgroup$ – Jacob Akkerboom Mar 31 '17 at 11:34
17
$\begingroup$

StringReplaceList

I just realized that there is a comparatively clean though not highly efficient way to write this using StringReplaceList:

op = Union @@ StringReplaceList[#, {"[]" -> "[[]]", "[]" -> "[][]"}] &;

Nest[op, {"[]"}, 3] // Column
[[[[]]]]
[[[][]]]
[[[]][]]
[[[]]][]
[[][[]]]
[[][][]]
[[][]][]
[[]][[]]
[[]][][]
[][[[]]]
[][[][]]
[][[]][]
[][][[]]
[][][][]

Better recursion

Replacing my earlier recursive method, this time avoiding redundancy. I keep track of the number of open and close brackets as each builds toward n.

f[n_] := f[n, 1, 0, "["]

f[n_, n_, c_, r_] := {r <> ConstantArray["]", n - c]}

f[n_, o_, c_, r_] /; c < o := 
  f[n, o + 1, c, r <> "["] ~Join~ f[n, o, c + 1, r <> "]"]

f[n_, o_, c_, r_] := f[n, o + 1, c, r <> "["] 

f[4]
{"[[[[]]]]", "[[[][]]]", "[[[]][]]", "[[[]]][]",
 "[[][[]]]", "[[][][]]", "[[][]][]", "[[]][[]]",
 "[[]][][]", "[][[[]]]", "[][[][]]", "[][[]][]",
 "[][][[]]", "[][][][]"}

Reasonably usable:

(* D24 *)

f[12] // Length // RepeatedTiming
{1.15, 208012}

Benchmarking

Here is a benchmark of various methods posted. All functions modified to use n rather than n/2.

Now using gwr's simplified code

(* Coolwater's method as a function *)
cw[n_] := 
 StringJoin @@@ (Pick[#, Min@*Accumulate /@ #, 0] &[
     Permutations[Join[#, -#] &[ConstantArray[1, n]]]] /. {-1 -> "]", 1 -> "["})

op = Union @@ StringReplaceList[#, {"[]" -> "[[]]", "[]" -> "[][]"}] &;
f2[n_] := Nest[op, {"[]"}, n - 1]

(* f code as above *)

Needs["GeneralUtilities`"]

BenchmarkPlot[{DyckWord, f, f2, cw, dyckWords}, # &, Range @ 12, 
  "IncludeFits" -> True, TimeConstraint -> 10]

enter image description here

| improve this answer | |
$\endgroup$
  • $\begingroup$ looks great - will have a play aroud with it - thanks! $\endgroup$ – martin Mar 27 '17 at 20:05
  • $\begingroup$ @martin I knew filtering was a sign of a bad algorithm. Please see my new code that avoids this. $\endgroup$ – Mr.Wizard Mar 27 '17 at 20:23
  • 1
    $\begingroup$ Re the latest, I was just about to post the same thing with rule x_ -> "[]" ~~ x $\endgroup$ – Simon Woods Mar 27 '17 at 22:27
  • $\begingroup$ @Simon Very concise! But it comes at the cost of more redundancy that has to be filtered out with Union. Can you think of a pattern that gives less redundancy? $\endgroup$ – Mr.Wizard Mar 27 '17 at 22:42
  • $\begingroup$ I cannot. I think there might be a neat method using Groupings, but it's bedtime here. $\endgroup$ – Simon Woods Mar 27 '17 at 22:51
7
$\begingroup$

This should work

d = 16
If[EvenQ[d], StringJoin @@@ (Pick[#, Min@*Accumulate /@ #, 0] &[
 Permutations[Join[#, -#] &[ConstantArray[1, d/2]]]] /. {-1 -> "]", 1 -> "["})]
| improve this answer | |
$\endgroup$
  • $\begingroup$ As filtering approaches go this is a nice one! $\endgroup$ – Mr.Wizard Mar 27 '17 at 20:21
  • $\begingroup$ Teeny simplification over Coolwater's nice answer: f[d_?EvenQ] := StringJoin @@@ (Pick[#, Min@*Accumulate /@ #, 0] &[ Permutations[Join[#, -#] &[ConstantArray[1, d/2]]]] /. {-1 -> "]", 1 -> "["}) $\endgroup$ – David G. Stork Mar 27 '17 at 21:38
7
$\begingroup$

Maybe something like this:

Test for Dyck words

We could test for Dyck words by consistently replacing "[ ]" with the empty word $\epsilon$. If the sequence of parentheses is a Dyck word, then in the end we must obtain the empty word. Thus:

DyckWordQ[ s_String ] := With[
    {
        f = StringReplace[
              {
                  "[" ~~ Whitespace ~~ "]" -> "", 
                  "[]"                     -> ""
              }
        ]
    },
    If[
        FixedPoint[ f, s ] === "",
        (* then *)        True,
        (* else *)        False,
        (* unevaluated *) False
    ]
]

Constructor for Dyck words

We could then use this to select valid Dyck words from all possible permutations.

DyckWord[ n_Integer ] /; EvenQ[n] := With[
    {
        p = Permutations[ ConstantArray[ "[", n/2 ] ~ Join ~ ConstantArray[ "]", n/2] ]
    },
    p // RightComposition[
        Map[ StringJoin ],
        Select[#, DyckWordQ] &
    ]
]

DyckWord[8]

{"[[[[]]]]", "[[[][]]]", "[[[]][]]", "[[[]]][]", "[[][[]]]", \ "[[][][]]", "[[][]][]", "[[]][[]]", "[[]][][]", "[][[[]]]", \ "[][[][]]", "[][[]][]", "[][][[]]", "[][][][]"}

| improve this answer | |
$\endgroup$
  • $\begingroup$ I wanted to benchmark this code but it does not copy and paste properly. Would you please check it? $\endgroup$ – Mr.Wizard Mar 27 '17 at 22:29
  • 2
    $\begingroup$ @Mr.Wizard There is a missing ] after n/2. This runs for me. With[{p = Permutations[ConstantArray[0, n/2]~Join~ConstantArray[1, n/2]]} $\endgroup$ – bobbym Mar 28 '17 at 3:14
  • $\begingroup$ @Mr.Wizard Thanks for the edit; it was kind of late when I pasted this. While it is not the fastest method, I would argue, that it is quite readable, a feature I often find rather important looking at what differences in timing we are talking about here... :) $\endgroup$ – gwr Mar 28 '17 at 5:53
  • 1
    $\begingroup$ @gwr also development time. If it takes 1 hour to come up with something that runs in .02 seconds and 5 minutes development time for something that runs in 5 seconds... " Remember also the human overhead of writing this if it is not going to be used many times.- Mr.Wizard" But since this might be used many times and for larger ones... $\endgroup$ – bobbym Mar 28 '17 at 9:07
  • $\begingroup$ @bobbym Sure, but try f[16] or cw[16] (D32) and see how fast that is... f[18] will probably take around 50 minutes already. $\endgroup$ – gwr Mar 28 '17 at 9:50
4
$\begingroup$

Not fast, but quite pleasing IMO, using Groupings

f[x_, y_] := f[x] <> "[" <> f[y] <> "]"
f[s_String] := s
f[_Integer] := ""

dyck[n_] := Groupings[n + 1, f -> 2]

dyck[4]

(* {"[][][][]", "[[][][]]", "[[][]][]", "[[[][]]]", 
"[[]][][]", "[[[]][]]", "[[[]]][]", "[[[[]]]]", "[][[]][]", 
"[[][[]]]", "[][][[]]", "[][[][]]", "[[]][[]]", "[][[[]]]"} *)
| improve this answer | |
$\endgroup$
  • $\begingroup$ Unfortunately I cannot test or benchmark this in v10.1 $\endgroup$ – Mr.Wizard Mar 28 '17 at 22:59
4
$\begingroup$

I made a function using LibraryLink. It uses the same algorithm as the one in J.M.'s answer, i.e. algorithm P by Knuth. Here is the C code

#include "WolframLibrary.h"
#include <stdlib.h>
#include <stdbool.h>

static char* charbuf;
static mint curword;
static mint zz;

/* Return the version of Library Link */
DLLEXPORT mint WolframLibrary_getVersion( ) {
    return WolframLibraryVersion;
}

/* Initialize Library */
DLLEXPORT int WolframLibrary_initialize( WolframLibraryData libData) {
    return LIBRARY_NO_ERROR;
}

/* Uninitialize Library */
DLLEXPORT void WolframLibrary_uninitialize( WolframLibraryData libData) {
    return;
}

DLLEXPORT int set_permup_buf(WolframLibraryData libData,
                             mint Argc, MArgument *Args, MArgument Res){

    //    '[' = 0      and    ']' = 1

    curword = 0;
    zz = MArgument_getInteger(Args[0]);

    mint qq = MArgument_getInteger(Args[1]);
    //sizeof(char) == 1 is guaranteed by the C standard. 
    charbuf = malloc(qq * (zz + 1));

    mint mm = zz - 1;
    mint jj;

    char aAr[zz + 1];
    int rowNum = 0;

    char b = 1;
    char* aPtr = aAr;

    //    p1
    for(int kk = 0; kk <= zz; kk++){
        *aPtr = b;
        aPtr++;
        b = !b;
    }

p2: {
    for(int dd = 0; dd < zz; dd++){
        charbuf[(zz + 1)*rowNum + dd] = 91 + 2 * aAr[dd+1];
    }
    charbuf[(zz+1)*rowNum + zz] = '\0';
    rowNum++;
}

    //p3
    aAr[mm] = 1;
    if(aAr[mm-1]){
        aAr[mm-1] = 0;
        mm--; goto p2;
    }

    //p4
    jj = mm - 1;
    int kk = zz - 1;
    while(! aAr[jj]){
        aAr[jj] = 1;
        aAr[kk] = 0;
        jj--;
        kk-=2;
    }

    //p5
    if(jj){
        aAr[jj] = 0;
        mm = zz - 1;
        goto p2;
    }

    return LIBRARY_NO_ERROR;
}

DLLEXPORT int get_permup_str(WolframLibraryData libData,
                             mint Argc, MArgument *Args, MArgument Res)
{
    MArgument_setUTF8String(Res, charbuf + curword*(zz+1));
    curword++;
    return LIBRARY_NO_ERROR;
}

DLLEXPORT int cleanup(WolframLibraryData libData,
                             mint Argc, MArgument *Args, MArgument Res)
{
    free(charbuf); //seems magical, doesn't it?
    return LIBRARY_NO_ERROR;
}

Loading the function

Save the code above at file at the path yourFileName (maybe the name of the file should end in .c) .

<< CCompilerDriver`
libName = "dyckwordlib";
lib2 = CreateLibrary[File@yourFileName, libName, "Debug" -> True];
setBuf = LibraryFunctionLoad[libName, 
   "set_permup_buf", {_Integer, _Integer}, "Void"];
getStr = LibraryFunctionLoad[libName, "get_permup_str", {}, 
   "UTF8String"];
cleanup = LibraryFunctionLoad[libName, "cleanup", {}, "Void"];
dyckWordsLibl[kwnn_] :=
 Module[{kn, qq, res}
  ,
  qq = CatalanNumber[kwnn];
  setBuf[2 kwnn, qq];
  res = Table[
    getStr[]
    ,
    qq
    ];
  cleanup[];
  res
  ]

Timings and naive memory tracking.

We see that the LibraryLink solution is fast. It also does not consume much memory, although I am pretty sure the memory monitoring tools of Mathematica don't accurately track the memory used.

MaxMemoryUsed[dyckWordsLibl[12]]
resJac = dyckWordsLibl[12]; // RepeatedTiming // First
MaxMemoryUsed[dyckWordsCc[24]]
resCc = dyckWordsCc[24]; // RepeatedTiming // First
MaxMemoryUsed[f[12]]
resWiz = f[12]; // RepeatedTiming // First
14978472
0.10
159753824
0.34
16641256
1.397

Of course the results are the same

Sort[resJac]  === Sort[resCc] === Sort[resWiz]
True

Using (slight adaptations of) definitions from especially Mr.Wizards answer, we get the following BenchmarkPlot

Needs["GeneralUtilities`"]

BenchmarkPlot[{wizf, f2, cw, dyckWordsCcDouble, dyckWordsLibl}, # &, 
 Range[2, 15], "IncludeFits" -> True, TimeConstraint -> 10]

enter image description here

Considerations about MaxMemoryUsed

Considering that on most platforms a char is encoded in one byte (and on mine in particular), the real memory used by our function is the following (a bit more than Mr.Wizard's function)

With[{kwnn = 12,
  qq = CatalanNumber[kwnn]},
 ByteCount@resJac + qq * (2 kwnn + 1) ]
20177244

Below, we will show below that MaxMemoryUsed does not track all the memory used by comparing the value MaxMemoryUsed[setBuf[2 kwnn, qq]], which is very small, with an alternative measurement.

We can track the increase in memory using a performance monitoring tool, in my case on OSX I used Activity Monitor. The increase in memory used by the WolframKernel process closely corresponds to the amount of memory we asked for using malloc. We set before and after to correspond to the values we see in activity monitor. We increase kwnn to 16 to make the memory use stand out even more.

before = Quantity[52.2, "Megabytes"];    
kwnn = 16;
qq = CatalanNumber[kwnn];
MaxMemoryUsed[setBuf[2 kwnn, qq]]
112

Of course this number 112 does not really make sense. We look again in activity monitor

after = Quantity[1.14, "Gigabytes"];

Incidentally, using the tool we can now see that cleanup works

cleanup[]; (*look in the tool after this command*)

Now we compare

Module[{kwnn = 16,
  qq },
 qq = CatalanNumber[kwnn];
  N@UnitConvert[qq * (2 kwnn + 1) Quantity[1, "Bytes"] , 
   Quantity[1, "Megabytes"]]]
  after - before
1166.8 MB
1087.8 MB

We see that we memory we used roughly corresponds to the memory we asked for. Furthermore, using the tool (activity monitor) we can see that cleanup works and all our memory is returned to us, so thats nice.

| improve this answer | |
$\endgroup$
3
$\begingroup$

Here is a compiled implementation of an algorithm due to Kása:

dyckPos = Compile[{{n, _Integer}},
                  Module[{m = Quotient[n, 2], b, chk, db},
                         b = Range[2, n, 2]; db = Internal`Bag[Most[{1}]];
                         While[Internal`StuffBag[db, b, 1];
                               chk = False;
                               Do[If[b[[j]] < m + j, b[[j]]++;
                                     Do[b[[i]] = Max[b[[i - 1]] + 1, 2 i],
                                        {i, j + 1, m - 1}];
                                     chk = True; Break[]],
                                  {j, m - 1, 1, -1}];
                               chk];
                         Partition[Internal`BagPart[db, All], m]],
                  RuntimeOptions -> "Speed"]

dyckWords[n_Integer?EvenQ] := 
    Table[StringJoin[ReplacePart[Range[n], {(Alternatives @@ pos) -> "]", _ -> "["}]],
          {pos, dyckPos[n]}]

Using the OP's example:

dyckWords[8]
   {"[][][][]", "[][][[]]", "[][[]][]", "[][[][]]", "[][[[]]]", "[[]][][]", "[[]][[]]",
    "[[][]][]", "[[][][]]", "[[][[]]]", "[[[]]][]", "[[[]][]]", "[[[][]]]", "[[[[]]]]"}
| improve this answer | |
$\endgroup$

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.