module Data.Algorithms.Palindromes.Palindromes
(longestPalindrome
,maximalPalindromes
,maximalPalindromesLengthAtLeast
,maximalPalindromesLengthBetween
,maximalPalindromesLengthAtMost
,palindromesLengthExact
,lengthLongestPalindrome
,lengthMaximalPalindromes
,longestTextPalindrome
,maximalTextPalindromesLengthAtLeast
,longestWordPalindrome
,maximalWordPalindromesLengthAtLeast
,palindromesAroundCentres
,myIsLetterC
) where
import Data.List (maximumBy,intercalate)
import Data.Word
import Data.Char (toLower,isPunctuation,isSpace,isControl)
import Data.Array (Array(),bounds,listArray,(!))
import qualified Data.ByteString as B
import Data.ByteString.Internal
longestPalindrome :: B.ByteString -> String
longestPalindrome input =
let (maxLength,pos) = maximumBy
(\(l,_) (l',_) -> compare l l')
(zip (palindromesAroundCentres input) [0..])
in showPalindrome input (maxLength,pos)
maximalPalindromes :: B.ByteString -> String
maximalPalindromes input =
intercalate "\n"
$ map (showPalindrome input)
$ zip (palindromesAroundCentres input) [0..]
maximalPalindromesLengthAtLeast :: Int -> B.ByteString -> String
maximalPalindromesLengthAtLeast m input =
intercalate "\n"
$ map (showPalindrome input)
$ filter ((m<=) . fst)
$ zip (palindromesAroundCentres input) [0..]
maximalPalindromesLengthBetween :: Int -> Int -> B.ByteString -> String
maximalPalindromesLengthBetween m n input =
intercalate "\n"
$ map (showPalindrome input)
$ filter (\(pl,_) -> pl >= m && pl <= n)
$ zip (palindromesAroundCentres input) [0..]
maximalPalindromesLengthAtMost :: Int -> B.ByteString -> String
maximalPalindromesLengthAtMost m input =
intercalate "\n"
$ map (showPalindrome input)
$ filter ((<=m) . fst)
$ zip (palindromesAroundCentres input) [0..]
palindromesLengthExact :: Int -> B.ByteString -> String
palindromesLengthExact m input =
intercalate "\n"
$ map (showPalindrome input . \(_,p) -> (m,p))
$ filter (\(l,_) -> m<=l && (odd l == odd m))
$ zip (palindromesAroundCentres input) [0..]
lengthLongestPalindrome :: B.ByteString -> String
lengthLongestPalindrome = show . maximum . palindromesAroundCentres
lengthMaximalPalindromes :: B.ByteString -> String
lengthMaximalPalindromes = show . palindromesAroundCentres
longestTextPalindrome :: B.ByteString -> String
longestTextPalindrome input =
let textInput = B.map myToLower (B.filter myIsLetterW input)
positionTextInput = listArrayl0 (B.findIndices myIsLetterW input)
in longestTextPalindromeBS input textInput positionTextInput
longestTextPalindromeBS :: B.ByteString -> B.ByteString -> Array Int Int -> String
longestTextPalindromeBS input textInput positionTextInput =
let (len,pos) = maximumBy
(\(l,_) (l',_) -> compare l l')
(zip (palindromesAroundCentres textInput) [0..])
in showTextPalindrome input positionTextInput (len,pos)
maximalTextPalindromesLengthAtLeast :: Int -> B.ByteString -> String
maximalTextPalindromesLengthAtLeast m input =
let textInput = B.map myToLower (B.filter myIsLetterW input)
positionTextInput = listArrayl0 (B.findIndices myIsLetterW input)
in intercalate "\n"
$ maximalTextPalindromesLengthAtLeastBS m textInput positionTextInput input
maximalTextPalindromesLengthAtLeastBS :: Int -> B.ByteString -> Array Int Int -> B.ByteString -> [String]
maximalTextPalindromesLengthAtLeastBS m textInput positionTextInput input =
map (showTextPalindrome input positionTextInput)
$ filter ((m<=) . fst)
$ zip (palindromesAroundCentres textInput) [0..]
palindromesAroundCentres :: B.ByteString -> [Int]
palindromesAroundCentres input = reverse $ extendPalindrome input 0 0 []
extendPalindrome :: B.ByteString -> Int -> Int -> [Int] -> [Int]
extendPalindrome input rightmost currentPalindrome currentMaximalPalindromes
| rightmost > last
= finalPalindromes currentPalindrome currentMaximalPalindromes (currentPalindrome:currentMaximalPalindromes)
| rightmostcurrentPalindrome == first ||
B.index input rightmost /= B.index input (rightmostcurrentPalindrome1)
= moveCenter input rightmost (currentPalindrome:currentMaximalPalindromes) currentMaximalPalindromes currentPalindrome
| otherwise
= extendPalindrome input (rightmost+1) (currentPalindrome+2) currentMaximalPalindromes
where first = 0
last = B.length input 1
moveCenter :: B.ByteString -> Int -> [Int] -> [Int] -> Int -> [Int]
moveCenter input rightmost currentMaximalPalindromes previousMaximalPalindromes centreDistance
| centreDistance == 0
= extendPalindrome input (rightmost+1) 1 currentMaximalPalindromes
| centreDistance1 == head previousMaximalPalindromes
= extendPalindrome input rightmost (head previousMaximalPalindromes) currentMaximalPalindromes
| otherwise
= moveCenter input rightmost (min (head previousMaximalPalindromes) (centreDistance1):currentMaximalPalindromes) (tail previousMaximalPalindromes) (centreDistance1)
finalPalindromes :: Int -> [Int] -> [Int] -> [Int]
finalPalindromes nrOfCenters previousMaximalPalindromes currentMaximalPalindromes
| nrOfCenters == 0
= currentMaximalPalindromes
| nrOfCenters > 0
= finalPalindromes (nrOfCenters1) (tail previousMaximalPalindromes) (min (head previousMaximalPalindromes) (nrOfCenters1):currentMaximalPalindromes)
| otherwise = error "finalCentres: input < 0"
maximalWordPalindromesLengthAtLeast :: Int -> B.ByteString -> String
maximalWordPalindromesLengthAtLeast m input =
let textInput = B.map myToLower (B.filter myIsLetterW input)
positionTextInput = listArrayl0 (B.findIndices myIsLetterW input)
in intercalate "\n"
$ maximalWordPalindromesLengthAtLeastBS m input textInput positionTextInput
maximalWordPalindromesLengthAtLeastBS :: Int -> B.ByteString -> B.ByteString -> Array Int Int -> [String]
maximalWordPalindromesLengthAtLeastBS m input textInput positionTextInput =
map (showTextPalindrome input positionTextInput)
$ filter ((m<=) . fst)
$ zip (wordPalindromesAroundCentres input textInput positionTextInput) [0..]
longestWordPalindrome :: B.ByteString -> String
longestWordPalindrome input =
let textInput = B.map myToLower (B.filter myIsLetterW input)
positionTextInput = listArrayl0 (B.findIndices myIsLetterW input)
(len,pos) = maximumBy
(\(w,_) (w',_) -> compare w w')
(zip (wordPalindromesAroundCentres input textInput positionTextInput) [0..])
in showTextPalindrome input positionTextInput (len,pos)
wordPalindromesAroundCentres :: B.ByteString -> B.ByteString -> Array Int Int -> [Int]
wordPalindromesAroundCentres input textInput positionTextInput =
let tfirst = 0
in reverse $ map (head . snd) $ extendTailWord input textInput positionTextInput [] tfirst (0,[0])
extendTailWord :: B.ByteString -> B.ByteString -> Array Int Int -> [(Int,[Int])] -> Int -> (Int,[Int]) -> [(Int,[Int])]
extendTailWord input textInput positionTextInput centres n current@(currentTail,currentTailWords)
| n > alast =
finalWordCentres input textInput positionTextInput (current:centres) currentTail centres (1+length centres)
| ncurrentTail == afirst =
extendWordCentres input textInput positionTextInput (current:centres) n centres currentTail
| B.index textInput n == B.index textInput (ncurrentTail1) =
if surroundedByPunctuation (positionTextInput!(ncurrentTail1)) (positionTextInput!n) input
then extendTailWord input textInput positionTextInput centres (n+1) (currentTail+2,currentTail+2:currentTailWords)
else extendTailWord input textInput positionTextInput centres (n+1) (currentTail+2,currentTailWords)
| otherwise =
extendWordCentres input textInput positionTextInput (current:centres) n centres currentTail
where (afirst,alast) = (0,B.length textInput 1)
extendWordCentres :: B.ByteString -> B.ByteString -> Array Int Int -> [(Int,[Int])] -> Int -> [(Int,[Int])] -> Int -> [(Int,[Int])]
extendWordCentres input textInput positionTextInput centres n tcentres centreDistance
| centreDistance == 0 =
if surroundedByPunctuation (positionTextInput!n) (positionTextInput!n) input
then extendTailWord input textInput positionTextInput centres (n+1) (1,[1,0])
else extendTailWord input textInput positionTextInput centres (n+1) (1,[0])
| centreDistance1 == fst (head tcentres) =
let (currentTail,oldWord:oldWords) = head tcentres
in if surroundedByPunctuation (positionTextInput!(ncurrentTail)) (positionTextInput!(n1)) input
then if oldWord == currentTail
then extendTailWord input textInput positionTextInput centres n (head tcentres)
else extendTailWord input textInput positionTextInput centres n (currentTail,currentTail:oldWord:oldWords)
else if oldWord == currentTail && oldWord > 0
then extendTailWord input textInput positionTextInput centres n (currentTail, tail (snd (head tcentres)))
else extendTailWord input textInput positionTextInput centres n (head tcentres)
| otherwise =
let newTail = min (fst (head tcentres)) (centreDistance1)
oldWord = head (snd (head tcentres))
newWords | oldWord < newTail
= if surroundedByPunctuation (positionTextInput!(nnewTail+1)) (positionTextInput!n) input
then newTail:snd (head tcentres)
else snd (head tcentres)
| null (tail (snd (head tcentres)))
= snd (head tcentres)
| otherwise
= tail (snd (head tcentres))
in extendWordCentres input textInput positionTextInput ((newTail,newWords):centres) n (tail tcentres) (centreDistance1)
finalWordCentres :: B.ByteString -> B.ByteString -> Array Int Int -> [(Int,[Int])] -> Int -> [(Int,[Int])] -> Int -> [(Int,[Int])]
finalWordCentres input textInput positionTextInput centres n tcentres mirrorPoint
| n == 0 = centres
| n > 0 = let tlast = B.length textInput 1
(oldTail,oldWord:oldWords) = head tcentres
newTail = min oldTail (n1)
newWord = min oldWord (n1)
tailFirstMirror = min tlast (div (mirrorPoint newTail) 2)
tailLastMirror = min tlast (if odd newTail then div (mirrorPoint + newTail) 2 else div (mirrorPoint + newTail) 2 1)
wordFirstMirror = min tlast (div (mirrorPoint newWord) 2)
wordLastMirror = min tlast (if odd newWord then div (mirrorPoint + newTail) 2 else div (mirrorPoint + newTail) 2 1)
newWords | surroundedByPunctuation (positionTextInput!tailFirstMirror) (positionTextInput!tailLastMirror) input
= if newWord == newTail
then newTail:oldWords
else newTail:oldWord:oldWords
| surroundedByPunctuation (positionTextInput!wordFirstMirror) (positionTextInput!wordLastMirror) input ||
null oldWords = newWord:oldWords
| otherwise = oldWords
in finalWordCentres input textInput positionTextInput ((newTail,newWords):centres) (n1) (tail tcentres) (mirrorPoint+1)
| otherwise = error "finalWordCentres: input < 0"
showPalindrome :: B.ByteString -> (Int,Int) -> String
showPalindrome input (len,pos) =
let startpos = pos `div` 2 len `div` 2
in show $ B.take len $ B.drop startpos input
showTextPalindrome :: B.ByteString -> Array Int Int -> (Int,Int) -> String
showTextPalindrome input positionTextInput (len,pos) =
let startpos = pos `div` 2 len `div` 2
endpos = if odd len
then pos `div` 2 + len `div` 2
else pos `div` 2 + len `div` 2 1
(pfirst,plast) = bounds positionTextInput
(ifirst,ilast) = (0,1 + B.length input)
in if endpos < startpos
then []
else let start = if startpos > pfirst
then (positionTextInput!(startpos1))+1
else ifirst
end = if endpos < plast
then (positionTextInput!(endpos+1))1
else ilast
in show (B.take (endstart+1) (B.drop start input))
myIsLetterW :: Word8 -> Bool
myIsLetterW c' = not (isPunctuation c)
&& not (isControl c)
&& not (isSpace c)
where c = w2c c'
myIsLetterC :: Char -> Bool
myIsLetterC c = not (isPunctuation c)
&& not (isControl c)
&& not (isSpace c)
myToLower :: Word8 -> Word8
myToLower = c2w . toLower . w2c
surroundedByPunctuation :: Int -> Int -> B.ByteString -> Bool
surroundedByPunctuation begin end input
| begin > afirst && end < alast = not (myIsLetterW (B.index input (begin1))) && not (myIsLetterW (B.index input (end+1)))
| begin <= afirst && end < alast = not (myIsLetterW (B.index input (end+1)))
| begin <= afirst && end >= alast = True
| begin > afirst && end >= alast = not (myIsLetterW (B.index input (begin1)))
| otherwise = error "surroundedByPunctuation"
where (afirst,alast) = (0,B.length input 1)
listArrayl0 :: [a] -> Array Int a
listArrayl0 string = listArray (0,length string 1) string