Largest palindrome from given string

Question

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"}

Answer 1

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.

Answer 2

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"

Answer 3

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"} *)

Answer 4

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.