palindromes-0.1: src/Data/Algorithm/Palindromes/Palindromes.hs
-----------------------------------------------------------------------------
-- |
-- Module : Data.Algorithm.Palindromes.Palindromes
-- Copyright : (c) 2007 - 2009 Johan Jeuring
-- License : BSD3
--
-- Maintainer : johan@jeuring.net
-- Stability : experimental
-- Portability : portable (requires ghc)
--
-----------------------------------------------------------------------------
module Data.Algorithm.Palindromes.Palindromes
(longestPalindrome
,longestPalindromes
,lengthLongestPalindrome
,lengthLongestPalindromes
,longestTextPalindrome
,longestTextPalindromes
,palindromesAroundCentres
) where
import Debug.Trace()
import Data.List (maximumBy,intersperse)
import Data.Char
import Data.Array
-- All functions in the interface, except palindromesAroundCentres
-- have the type String -> String
-----------------------------------------------------------------------------
-- longestPalindrome
-----------------------------------------------------------------------------
-- | longestPalindrome returns the longest palindrome in a string.
longestPalindrome :: String -> String
longestPalindrome input =
let inputArray = stringArray input
(maxLength,pos) = maximumBy
(\(l,_) (l',_) -> compare l l')
(zip (palindromesAroundCentres inputArray) [0..])
in showPalindrome inputArray (maxLength,pos)
-----------------------------------------------------------------------------
-- longestPalindromes
-----------------------------------------------------------------------------
-- | longestPalindromes returns the longest palindrome around each position
-- in a string.
longestPalindromes :: String -> String
longestPalindromes input =
let inputArray = stringArray input
in concat
$ intersperse "\n"
$ map (showPalindrome inputArray)
$ zip (palindromesAroundCentres inputArray) [0..]
-----------------------------------------------------------------------------
-- lengthLongestPalindrome
-----------------------------------------------------------------------------
-- | lengthLongestPalindrome returns the length of the longest palindrome in
-- a string.
lengthLongestPalindrome :: String -> String
lengthLongestPalindrome =
show . maximum . palindromesAroundCentres . stringArray
-----------------------------------------------------------------------------
-- lengthLongestPalindromes
-----------------------------------------------------------------------------
-- | lengthLongestPalindromes returns the lengths of the longest palindrome
-- around each position in a string.
lengthLongestPalindromes :: String -> String
lengthLongestPalindromes =
show . palindromesAroundCentres . stringArray
-----------------------------------------------------------------------------
-- longestTextPalindrome
-----------------------------------------------------------------------------
-- | longestTextPalindrome returns the longest text palindrome in a string,
-- ignoring spacing, punctuation symbols, and case of letters.
longestTextPalindrome :: String -> String
longestTextPalindrome input =
let inputArray = stringArray input
ips = zip input [0..]
textinput = map (\(i,p) -> (toLower i,p))
(filter (isLetter.fst) ips)
textInputArray = stringArray (map fst textinput)
lti = length textinput
positionTextInputArray = listArray (0,lti-1) (map snd textinput)
in longestTextPalindromeArray
textInputArray
positionTextInputArray
inputArray
longestTextPalindromeArray ::
(Show a, Eq a) => Array Int a -> Array Int Int -> Array Int a -> 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
-----------------------------------------------------------------------------
-- | longestTextPalindromes returns the longest text palindrome around each
-- position in a string.
longestTextPalindromes :: String -> String
longestTextPalindromes input =
let inputArray = stringArray input
ips = zip input [0..]
textinput = map (\(i,p) -> (toLower i,p))
(filter (isLetter.fst) ips)
textInputArray = stringArray (map fst textinput)
lti = length textinput
positionTextInputArray = listArray (0,lti-1) (map snd textinput)
in concat
$ intersperse "\n"
$ longestTextPalindromesArray
textInputArray
positionTextInputArray
inputArray
longestTextPalindromesArray ::
(Show a, Eq a) => Array Int a -> Array Int Int -> Array Int a -> [String]
longestTextPalindromesArray a positionArray inputArray =
map (showTextPalindrome positionArray inputArray)
(zip (palindromesAroundCentres a) [0..])
-----------------------------------------------------------------------------
-- palindromesAroundCentres
--
-- The function that implements the palindrome finding algorithm.
-- Used in all the interface functions.
-----------------------------------------------------------------------------
-- | palindromesAroundCentres is the central function of the module. It returns
-- the list of lenghths of the longest palindrome around each position in a
-- string.
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 =
-- reached the end of the array
finalCentres currentTail centres
(currentTail:centres)
| n-currentTail == afirst =
-- the current longest tail palindrome
-- extends to the start of the array
extendCentres a n (currentTail:centres)
centres currentTail
| a!n == a!(n-currentTail-1) =
-- the current longest tail palindrome
-- can be extended
extendTail a (n+1) (currentTail+2) centres
| otherwise =
-- the current longest tail palindrome
-- cannot be extended
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 =
-- the last centre is on the last element:
-- try to extend the tail of length 1
extendTail a (n+1) 1 centres
| centreDistance-1 == head tcentres =
-- the previous element in the centre list
-- reaches exactly to the end of the last
-- tail palindrome use the mirror property
-- of palindromes to find the longest tail
-- palindrome
extendTail a n (head tcentres) centres
| otherwise =
-- move the centres one step
-- add the length of the longest palindrome
-- to the centres
extendCentres a n (min (head tcentres)
(centreDistance-1):centres)
(tail tcentres) (centreDistance-1)
finalCentres :: Int -> [Int] -> [Int] -> [Int]
finalCentres 0 _ centres = centres
finalCentres (n+1) tcentres centres =
finalCentres n
(tail tcentres)
(min (head tcentres) n:centres)
finalCentres _ _ _ = error "finalCentres: input < 0"
-----------------------------------------------------------------------------
-- Showing palindreoms
-----------------------------------------------------------------------------
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
in if endpos < startpos
then []
else let start = if startpos > fst (bounds positionArray)
then positionArray!!!(startpos-1)+1
else fst (bounds inputArray)
end = if endpos < snd (bounds positionArray)
then positionArray!!!(endpos+1)-1
else snd (bounds inputArray)
in show $ [inputArray!n | n<- [start..end]]
-----------------------------------------------------------------------------
-- Array utils
-----------------------------------------------------------------------------
stringArray :: String -> Array Int Char
stringArray string = listArray (0,length string - 1) string
-- (!!!) is a variant of (!), which prints out the problem in case of
-- an index out of bounds.
(!!!) :: Array Int a -> Int -> a
a!!! n = if n >= fst (bounds a) && n <= snd (bounds a)
then a!n
else error (show (snd (bounds a)) ++ " " ++ show n)