module Data.Algorithms.Palindromes.Palindromes
(longestPalindrome
,longestPalindromes
,lengthLongestPalindrome
,lengthLongestPalindromes
,longestTextPalindrome
,longestTextPalindromes
,longestWordPalindrome
,longestWordPalindromes
,palindromesAroundCentres
,listArrayl0
) where
import Data.List (maximumBy,intersperse)
import Data.Char(toLower,isPunctuation,isSpace,isControl)
import Data.Array(Array(),bounds,listArray,(!))
import Control.Arrow
longestPalindrome :: (Eq a,Show a) => [a] -> String
longestPalindrome input =
let inputArray = listArrayl0 input
(maxLength,pos) = maximumBy
(\(l,_) (l',_) -> compare l l')
(zip (palindromesAroundCentres inputArray) [0..])
in showPalindrome inputArray (maxLength,pos)
longestPalindromes :: (Eq a,Show a) => Int -> [a] -> String
longestPalindromes m input =
let inputArray = listArrayl0 input
in concat
$ intersperse "\n"
$ map (showPalindrome inputArray)
$ filter ((m<=) . fst)
$ zip (palindromesAroundCentres inputArray) [0..]
lengthLongestPalindrome :: Eq a => [a] -> String
lengthLongestPalindrome =
show . maximum . palindromesAroundCentres . listArrayl0
lengthLongestPalindromes :: Eq a => [a] -> String
lengthLongestPalindromes =
show . palindromesAroundCentres . listArrayl0
longestTextPalindrome :: String -> String
longestTextPalindrome input =
let inputArray = listArrayl0 input
ips = zip input [0..]
textinput = map (first toLower)
(filter (myIsLetter.fst) ips)
textInputArray = listArrayl0 (map fst textinput)
positionTextInputArray = listArrayl0 (map snd textinput)
in longestTextPalindromeArray
textInputArray
positionTextInputArray
inputArray
longestTextPalindromeArray ::
Array Int Char -> Array Int Int -> Array Int Char -> String
longestTextPalindromeArray a positionArray inputArray =
let (len,pos) = maximumBy
(\(l,_) (l',_) -> compare l l')
(zip (palindromesAroundCentres a) [0..])
in showTextPalindrome positionArray inputArray (len,pos)
longestTextPalindromes :: Int -> String -> String
longestTextPalindromes m input =
let inputArray = listArrayl0 input
ips = zip input [0..]
textinput = map (first toLower)
(filter (myIsLetter.fst) ips)
textInputArray = listArrayl0 (map fst textinput)
positionTextInputArray = listArrayl0 (map snd textinput)
in concat
$ intersperse "\n"
$ longestTextPalindromesArray
m
textInputArray
positionTextInputArray
inputArray
longestTextPalindromesArray ::
Int -> Array Int Char -> Array Int Int -> Array Int Char -> [String]
longestTextPalindromesArray m a positionArray inputArray =
map (showTextPalindrome positionArray inputArray)
$ filter ((m<=) . fst)
$ zip (palindromesAroundCentres a) [0..]
palindromesAroundCentres :: Eq a => Array Int a -> [Int]
palindromesAroundCentres a =
let (afirst,_) = bounds a
in reverse $ extendTail a afirst 0 []
extendTail :: Eq a => Array Int a -> Int -> Int -> [Int] -> [Int]
extendTail a n currentTail centres
| n > alast =
finalCentres currentTail centres (currentTail:centres)
| ncurrentTail == afirst =
extendCentres a n (currentTail:centres) centres currentTail
| (a!n) == (a!(ncurrentTail1)) =
extendTail a (n+1) (currentTail+2) centres
| otherwise =
extendCentres a n (currentTail:centres) centres currentTail
where (afirst,alast) = bounds a
extendCentres :: Eq a => Array Int a -> Int -> [Int] -> [Int] -> Int -> [Int]
extendCentres a n centres tcentres centreDistance
| centreDistance == 0 =
extendTail a (n+1) 1 centres
| centreDistance1 == head tcentres =
extendTail a n (head tcentres) centres
| otherwise =
extendCentres a n (min (head tcentres) (centreDistance1):centres) (tail tcentres) (centreDistance1)
finalCentres :: Int -> [Int] -> [Int] -> [Int]
finalCentres n tcentres centres
| n == 0 = centres
| n > 0 = finalCentres (n1) (tail tcentres) (min (head tcentres) (n1):centres)
| otherwise = error "finalCentres: input < 0"
longestWordPalindromes :: Int -> String -> String
longestWordPalindromes m input =
let inputArray = listArrayl0 input
ips = zip input [0..]
textinput = map (first toLower)
(filter (myIsLetter.fst) ips)
textInputArray = listArrayl0 (map fst textinput)
positionTextInputArray = listArrayl0 (map snd textinput)
in concat
$ intersperse "\n"
$ longestWordPalindromesArray
m
textInputArray
positionTextInputArray
inputArray
longestWordPalindromesArray :: Int -> Array Int Char -> Array Int Int -> Array Int Char -> [String]
longestWordPalindromesArray m textInputArray positionArray inputArray =
map (showTextPalindrome positionArray inputArray)
$ filter ((m<=) . fst)
$ zip (wordPalindromesAroundCentres textInputArray positionArray inputArray) [0..]
longestWordPalindrome :: String -> String
longestWordPalindrome input =
let inputArray = listArrayl0 input
ips = zip input [0..]
textinput = map (first toLower)
(filter (myIsLetter.fst) ips)
textInputArray = listArrayl0 (map fst textinput)
positionArray = listArrayl0 (map snd textinput)
(maxLength,pos) = maximumBy
(\(w,_) (w',_) -> compare w w')
(zip (wordPalindromesAroundCentres textInputArray positionArray inputArray) [0..])
in showTextPalindrome positionArray inputArray (maxLength,pos)
wordPalindromesAroundCentres :: Array Int Char -> Array Int Int -> Array Int Char -> [Int]
wordPalindromesAroundCentres textInputArray positionArray inputArray =
let (afirst,_) = bounds textInputArray
in reverse $ map (head . snd) $ extendTailWord textInputArray positionArray inputArray afirst (0,[0]) []
extendTailWord :: Array Int Char -> Array Int Int -> Array Int Char -> Int -> (Int,[Int]) -> [(Int,[Int])] -> [(Int,[Int])]
extendTailWord textInputArray positionArray inputArray n current@(currentTail,currentTailWords) centres
| n > alast =
finalWordCentres textInputArray positionArray inputArray currentTail centres (current:centres) (1+length centres)
| ncurrentTail == afirst =
extendWordCentres textInputArray positionArray inputArray n (current:centres) centres currentTail
| (textInputArray!!!n) == (textInputArray!!!(ncurrentTail1)) =
if surroundedByPunctuation (positionArray!!!(ncurrentTail1)) (positionArray!!!n) inputArray
then
extendTailWord textInputArray positionArray inputArray (n+1) (currentTail+2,currentTail+2:currentTailWords) centres
else
extendTailWord textInputArray positionArray inputArray (n+1) (currentTail+2,currentTailWords) centres
| otherwise =
extendWordCentres textInputArray positionArray inputArray n (current:centres) centres currentTail
where (afirst,alast) = bounds textInputArray
extendWordCentres :: Array Int Char -> Array Int Int -> Array Int Char -> Int -> [(Int,[Int])] -> [(Int,[Int])] -> Int -> [(Int,[Int])]
extendWordCentres textInputArray positionArray inputArray n centres tcentres centreDistance
| centreDistance == 0 =
if surroundedByPunctuation (positionArray!n) (positionArray!n) inputArray
then
extendTailWord textInputArray positionArray inputArray (n+1) (1,[1,0]) centres
else
extendTailWord textInputArray positionArray inputArray (n+1) (1,[0]) centres
| centreDistance1 == fst (head tcentres) =
let (currentTail,oldWord:oldWords) = head tcentres
in if surroundedByPunctuation (positionArray!(ncurrentTail)) (positionArray!(n1)) inputArray
then if oldWord == currentTail
then
extendTailWord textInputArray positionArray inputArray n (head tcentres) centres
else
extendTailWord textInputArray positionArray inputArray n (currentTail,currentTail:oldWord:oldWords) centres
else if oldWord == currentTail && oldWord > 0
then
extendTailWord textInputArray positionArray inputArray n (currentTail, tail (snd (head tcentres))) centres
else
extendTailWord textInputArray positionArray inputArray n (head tcentres) centres
| otherwise =
let newTail = min (fst (head tcentres)) (centreDistance1)
oldWord = head (snd (head tcentres))
newWords = if oldWord < newTail
then if surroundedByPunctuation (positionArray!(nnewTail+1)) (positionArray!n) inputArray
then newTail:snd (head tcentres)
else snd (head tcentres)
else if null (tail (snd (head tcentres)))
then snd (head tcentres)
else tail (snd (head tcentres))
in
extendWordCentres textInputArray positionArray inputArray n ((newTail,newWords):centres) (tail tcentres) (centreDistance1)
finalWordCentres :: Array Int Char -> Array Int Int -> Array Int Char -> Int -> [(Int,[Int])] -> [(Int,[Int])] -> Int -> [(Int,[Int])]
finalWordCentres textInputArray positionArray inputArray n tcentres centres mirrorPoint
| n == 0 = centres
| n > 0 = let (_,tlast) = bounds textInputArray
(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 = if
surroundedByPunctuation (positionArray!tailFirstMirror) (positionArray!tailLastMirror) inputArray
then if newWord == newTail
then newTail:oldWords
else newTail:oldWord:oldWords
else if
surroundedByPunctuation (positionArray!wordFirstMirror) (positionArray!wordLastMirror) inputArray
then newWord:oldWords
else if null oldWords then newWord:oldWords else oldWords
in
finalWordCentres textInputArray positionArray inputArray (n1) (tail tcentres) ((newTail,newWords):centres) (mirrorPoint+1)
| otherwise = error "finalWordCentres: input < 0"
showPalindrome :: (Show a) => Array Int a -> (Int,Int) -> String
showPalindrome a (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
in show [a!n|n <- [startpos .. endpos]]
showTextPalindrome :: (Show a) =>
Array Int Int -> Array Int a -> (Int,Int) -> String
showTextPalindrome positionArray inputArray (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 positionArray
(ifirst,ilast) = bounds inputArray
in if endpos < startpos
then []
else let start = if startpos > pfirst
then (positionArray!(startpos1))+1
else ifirst
end = if endpos < plast
then (positionArray!(endpos+1))1
else ilast
in show [inputArray!n | n<- [start..end]]
myIsLetter :: Char -> Bool
myIsLetter c = (not $ isPunctuation c)
&& (not $ isControl c)
&& (not $ isSpace c)
surroundedByPunctuation :: Int -> Int -> Array Int Char -> Bool
surroundedByPunctuation begin end inputArray
| begin > afirst && end < alast = not (myIsLetter (inputArray!(begin1))) && not (myIsLetter (inputArray!(end+1)))
| begin <= afirst && end < alast = not (myIsLetter (inputArray!(end+1)))
| begin <= afirst && end >= alast = True
| begin > afirst && end >= alast = not (myIsLetter (inputArray!(begin1)))
| otherwise = error "surroundedByPunctuation"
where (afirst,alast) = bounds inputArray
listArrayl0 :: [a] -> Array Int a
listArrayl0 string = listArray (0,length string 1) string
(!!!) :: Array Int a -> Int -> a
a!!! n =
if n >= fst (bounds a) && n <= snd (bounds a)
then a!n
else error (show (fst (bounds a)) ++ " " ++ show (snd (bounds a)) ++ " " ++ show n)