13
$\begingroup$

Someone recently posted a request on LinkedIn for an algorithm to find the largest palindrome from a given string.

I came up with this, which I believe does the trick, but I am wondering if there are more elegant and/or faster solutions?

teststring = "ItellyoumadamthecatisnotacivicanimalalthoughtisdeifiedinEgypt"; 
nlargest = 5;

TakeLargestBy[Cases[StringCases[#1, __, Overlaps -> All], _?PalindromeQ], 
    StringLength, #2] &[teststring, nlargest] // Flatten

with result:

{"acivica", "deified", "eifie", "madam", "civic"}
$\endgroup$
2
  • 1
    $\begingroup$ Your code is corrupted, please fix it. $\endgroup$
    – Kuba
    Dec 5, 2016 at 19:19
  • 1
    $\begingroup$ PalindromeQ is new in 10.3.. in case anyone else has issues with this. $\endgroup$
    – george2079
    Dec 5, 2016 at 19:36

5 Answers 5

11
$\begingroup$

Manacher's algorithm is much faster than brute-force solutions. ($O(n)$ vs $O(n^3)$) Here's an implementation (it only returns the first longest palindrome though):

findLongestPalindrome[""] = "";
findLongestPalindrome[s_String] := 
    FromCharacterCode @ findLongestPalindromeList[ToCharacterCode @ s];

findLongestPalindromeList = Compile[{{s, _Integer, 1}},
    Module[{s2, p, c, r, n, m, i2, len, cc},
      s2 = Riffle[s, -1, {1, -1, 2}];
      p = ConstantArray[0, Length[s2]];
      c = 1; r = 1; m = 1; n = 1; len = 0; cc = 1;
      Do[
        If[i > r,
          p[[i]] = 0; m = i - 1; n = i + 1,
          i2 = 2 c - i;
          If[p[[i2]] < (r - i),
            p[[i]] = p[[i2]]; m = 0,
            p[[i]] = r - i; n = r + 1; m = 2 i - n
          ]
        ];
        If[OddQ[m],p[[i]]++; m--; n++];
        While[m > 0 && n <= Length[s2] && s2[[m]] == s2[[n]],
          p[[i]] += 2; m -= 2; n += 2;
        ];
        If[(i + p[[i]]) > r,
          c = i; r = i + p[[i]];
        ];
        If[len < p[[i]],
          len = p[[i]]; cc = i;
        ],
        {i,2,Length[s2]}
      ];
      s[[Quotient[cc - len + 1, 2] ;; Quotient[cc + len - 1, 2]]]
    ]
  ]

StringLength[aeneid] (* 606071 *)
AbsoluteTiming[findLongestPalindrome[aeneid]] (* {0.236135, "man nam"} *)

A simpler but not much more elegant solution that's $O(n^2)$ (actually, $O(nm)$ for $m$ is the length of the longest palindrome):

findLongestPalindrome[s_String] := Module[
    {ss = Characters @ s, even, odd, best = {}, i, j, n = 0},
    odd =  Reverse @ Range[Length[ss]];
    even = Reverse @ Range[Length[ss] - 1];
    While[Length[even] > 0 || Length[odd] > 0,
      odd  = Select[ odd, ({i,j} = {# - n, # + n    }; i > 0 && j <= Length[ss] &&
        ss[[i]] == ss[[j]] && (best = {i, j}; True)) &];
      even = Select[even, ({i,j} = {# - n, # + n + 1}; i > 0 && j <= Length[ss] &&
        ss[[i]] == ss[[j]] && (best = {i, j}; True)) &];
      n++;
    ];
    StringTake[s,best]
  ]

AbsoluteTiming[findLongestPalindrome[aeneid]] (* {7.8125, "man nam"} *)
$\endgroup$
1
  • 1
    $\begingroup$ 10 bonus points for the implementation of Manacher's algorithm. $\endgroup$ Dec 8, 2016 at 9:21
11
$\begingroup$

Brute force but more compact:

StringCases[
  teststring, 
  x : Repeated[LetterCharacter, {2, ∞}] /; PalindromeQ[x], 
  Overlaps -> True
] // MaximalBy[StringLength]

{"acivica", "deified"}

edit: I've replaced _ with LetterCharacter since we are not interested in palindromes across many words.

$\endgroup$
1
  • $\begingroup$ a better solution. I couldn't figure out how to get StringCases to work for this. $\endgroup$ Dec 5, 2016 at 19:40
9
$\begingroup$

A non-pattern version of Kuba's solution would be this:

MaximalBy[Select[
  StringJoin /@ Subsequences[Characters[str]],
  PalindromeQ
  ], StringLength]

{"acivica", "deified"}

The following is a solution in many cases, but Kuba noted that it only works if the string does not contain substrings which are reversed copies of each other, and happen to be longer than any real palindrome in the string.

str = "ItellyoumadamthecatisnotacivicanimalalthoughtisdeifiedinEgypt";    
str2 = StringReverse[str];

LongestCommonSubsequence[str, str2]

"acivica"

$\endgroup$
2
  • $\begingroup$ This doesn't appear to work. For example: Aeneid = ExampleData[{"Text", "AeneidEnglish"}]; LongestCommonSubsequence[teststring, StringReverse[teststring]] produces the answer: tes d $\endgroup$ Dec 6, 2016 at 9:37
  • $\begingroup$ @JonathanKinlay This is because of the same problem that Kuba pointed out to me, which I've remarked upon in my answer. Somewhere in the text is the reverse string, "d set". I guess you could add another caveat: it does not work well with spaces. However, spaces were not part of the original problem. $\endgroup$
    – C. E.
    Dec 6, 2016 at 9:53
3
$\begingroup$

Using Partition:

str = "ItellyoumadamthecatisnotacivicanimalalthoughtisdeifiedinEgypt";

Select[PalindromeQ][Partition[Characters@str, #, 1]] & /@ 
   Range[3, 8] // Flatten[#, 1] & // Map[StringJoin]

where the range can be adjusted as required.

EDIT

Using StringPartition:

After realizing (with a red face) that StringPartition is also available ...

Select[PalindromeQ][StringPartition[str, #, 1]] & /@ Range[3, 8] // 
 Flatten[#, 1] &

Result

{"ada", "ivi", "ala", "lal", "ifi", "madam", "civic", "eifie",
"acivica", "deified"}


Using SequenceCases:

SequenceCases can be used to isolate patterns that start and end at the same character. The palindromicity can be determined later on. The Overlaps feature of the command comes in handy.

SequenceCases[Characters@str, 
 k : {a_String, Shortest[__], a_String} :> 
  If[PalindromeQ[k], StringJoin @@ k, Nothing], Overlaps -> All] 

{"madam", "ada", "acivica", "civic", "ivi", "ala", "lal", "deified", "eifie", "ifi"}

$\endgroup$
1
  • $\begingroup$ (+1) Your code is a clever way! $\endgroup$ Sep 28, 2023 at 6:31
0
$\begingroup$
Aeneid = ExampleData[{"Text", "AeneidEnglish"}];
StringLength[Aeneid]
606071

teststring = StringTake[Aeneid, 1000];
nlargest = 20;

TakeLargestBy[Cases[StringCases[teststring, __, Overlaps -> All], _?PalindromeQ],
StringLength, nlargest] // Flatten // Timing

{16.2909, {"ivi", "t t", "a a", " I ", "ele", "t t", "ovo", " O ", " I ", "h h", "s s", "g g", "t t", "awa", "ses", "ese", " a ", "t t", "exe", "s s"}}

MaximalBy[Select[StringJoin /@ Subsequences[Characters[teststring]],
PalindromeQ], StringLength, nlargest] // Timing

{16.9451, {" I ", " I ", "ele", "t t", "a a", "t t", "ivi", "g g", " O ", "ses", "ovo", " a ", "s s", "h h", "ese", "exe", "t t", "awa", "t t", "s s"}}

MaximalBy[StringCases[teststring, x : Repeated[_, {2, \[Infinity]}] 
/; PalindromeQ[x], Overlaps -> True], StringLength, nlargest] // Timing

{12.1068, {" I ", " I ", "ele", "t t", "a a", "t t", "ivi", "g g", " O ", "ses", "ovo", " a ", "s s", "h h", "ese", "exe", "t t", "awa", "t t", "s s"}}

LongestCommonSubsequence[teststring, StringReverse[teststring]]

"tes d"

I declare C.E.'s first solution to be the winner. It is both the fastest and most elegant.

Not sure what is going on with C.E.'s second solution, which appears to fail completely.

$\endgroup$
1
  • 1
    $\begingroup$ I don't see how is 16.9 shorter than 12.1 $\endgroup$
    – Kuba
    Dec 6, 2016 at 9:51

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

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