palindromes 0.2.2.1 → 0.2.2.2
raw patch · 4 files changed
+281/−138 lines, 4 filesPVP: minor bump suggested
API additions: PVP suggests at least a minor version bump
API changes (from Hackage documentation)
+ Data.Algorithms.Palindromes.Palindromes: listArrayl0 :: [a] -> Array Int a
Files
- RELEASE_HISTORY +3/−0
- palindromes.cabal +1/−1
- src/Data/Algorithms/Palindromes/Palindromes.hs +45/−130
- tests/Main.hs +232/−7
RELEASE_HISTORY view
@@ -1,5 +1,8 @@ Release history: +190312 Version 0.2.2.2+Corrected a non-critical error in finalWordCentres+ 190312 Version 0.2.2.1 Corrected a link
palindromes.cabal view
@@ -1,5 +1,5 @@ name: palindromes-version: 0.2.2.1+version: 0.2.2.2 synopsis: Finding palindromes in strings homepage: http://www.jeuring.net/homepage/palindromes/index.html description:
src/Data/Algorithms/Palindromes/Palindromes.hs view
@@ -28,11 +28,13 @@ ,longestWordPalindrome ,longestWordPalindromes ,palindromesAroundCentres+ ,listArrayl0 ) where import Data.List (maximumBy,intersperse) import Data.Char(toLower,isPunctuation,isSpace,isControl) import Data.Array(Array(),bounds,listArray,(!)) +-- import Debug.Trace import Control.Arrow @@ -266,18 +268,23 @@ extendTailWord textInputArray positionArray inputArray n current@(currentTail,currentTailWords) centres | n > alast = -- reached the end of the text input array - finalWordCentres textInputArray positionArray inputArray currentTail centres (current:centres)+ -- trace ("ETW 1 " ++ show current ++ " " ++ "\n") $ + finalWordCentres textInputArray positionArray inputArray currentTail centres (current:centres) (1+length centres) | n-currentTail == afirst = -- the current longest tail palindrome extends to the start of the text input array+ -- trace ("ETW 2 " ++ show current ++ " " ++ "\n") $ extendWordCentres textInputArray positionArray inputArray n (current:centres) centres currentTail | (textInputArray!!!n) == (textInputArray!!!(n-currentTail-1)) = -- the current longest tail palindrome can be extended -- check whether or not the extended palindrome is a wordpalindrome if surroundedByPunctuation (positionArray!!!(n-currentTail-1)) (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 + then -- trace ("ETW 3 " ++ show (currentTail+2,currentTail+2:currentTailWords) ++ " " ++ "\n") $ + extendTailWord textInputArray positionArray inputArray (n+1) (currentTail+2,currentTail+2:currentTailWords) centres+ else -- trace ("ETW 4 " ++ show (currentTail+2,currentTailWords) ++ " " ++ show (n-currentTail-1) ++ " " ++ show n ++ "\n") $ + extendTailWord textInputArray positionArray inputArray (n+1) (currentTail+2,currentTailWords) centres | otherwise = -- the current longest tail palindrome cannot be extended + -- trace ("ETW 5" ++ "\n") $ extendWordCentres textInputArray positionArray inputArray n (current:centres) centres currentTail where (afirst,alast) = bounds textInputArray @@ -287,8 +294,10 @@ -- the last centre is on the last element: -- try to extend the tail of length 1 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+ then -- trace ("EWC 1 " ++ show [1,0] ++ " " ++ "\n") $ + extendTailWord textInputArray positionArray inputArray (n+1) (1,[1,0]) centres+ else -- trace ("EWC 2 " ++ show [0] ++ " " ++ "\n") $ + extendTailWord textInputArray positionArray inputArray (n+1) (1,[0]) centres | centreDistance-1 == fst (head tcentres) = -- the previous element in the centre list -- reaches exactly to the end of the last @@ -298,11 +307,15 @@ let (currentTail,oldWord:oldWords) = head tcentres in if surroundedByPunctuation (positionArray!(n-currentTail)) (positionArray!(n-1)) 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+ then -- trace ("EWC 3 " ++ show (head tcentres) ++ " " ++ "\n") $+ extendTailWord textInputArray positionArray inputArray n (head tcentres) centres+ else -- trace ("EWC 4 " ++ show (currentTail,currentTail:snd (head tcentres)) ++ " " ++ "\n") $+ 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+ then -- trace ("EWC 5 " ++ show (currentTail, tail (snd (head tcentres))) ++ " " ++ "\n") $+ extendTailWord textInputArray positionArray inputArray n (currentTail, tail (snd (head tcentres))) centres+ else -- trace ("EWC 6 " ++ show (head tcentres) ++ " " ++ show (n-currentTail) ++ " " ++ show (n-1) ++ "\n") $+ extendTailWord textInputArray positionArray inputArray n (head tcentres) centres | otherwise = -- move the centres one step -- add the length of the longest palindrome @@ -316,134 +329,34 @@ 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) (centreDistance-1)+ in -- trace ("EWC 7 " ++ show (newTail,newWords) ++ " " ++ "\n") $ + extendWordCentres textInputArray positionArray inputArray n ((newTail,newWords):centres) (tail tcentres) (centreDistance-1) -finalWordCentres :: Array Int Char -> Array Int Int -> Array Int Char -> Int -> [(Int,[Int])] -> [(Int,[Int])] -> [(Int,[Int])]-finalWordCentres textInputArray positionArray inputArray n tcentres centres +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 (n-1)- diff = if oldTail < n-1 then n - 1 - oldTail else 0- firstMirror = min tlast (tlast-diff-newTail+1)- lastMirror = tlast-diff- newWords = if oldWord < newTail - && surroundedByPunctuation (positionArray!firstMirror) (positionArray!lastMirror) inputArray- then newTail:oldWord:oldWords- else if null oldWords then oldWord:oldWords else oldWords- in finalWordCentres textInputArray positionArray inputArray (n-1) (tail tcentres) ((newTail,newWords):centres)+ newWord = min oldWord (n-1)+ 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 -- trace ("FWC !" ++ show (positionArray!tailFirstMirror) ++ " " ++ show (positionArray!tailLastMirror)) $+ surroundedByPunctuation (positionArray!tailFirstMirror) (positionArray!tailLastMirror) inputArray+ then if newWord == newTail+ then newTail:oldWords+ else newTail:oldWord:oldWords+ else if -- trace ("FWC !" ++ show (positionArray!wordFirstMirror) ++ " " ++ show (positionArray!wordLastMirror)) $+ surroundedByPunctuation (positionArray!wordFirstMirror) (positionArray!wordLastMirror) inputArray+ then newWord:oldWords+ else if null oldWords then newWord:oldWords else oldWords+ in -- trace ("FWC 1 " ++ " " ++ show (newTail,newWords) ++ "\n") $ + finalWordCentres textInputArray positionArray inputArray (n-1) (tail tcentres) ((newTail,newWords):centres) (mirrorPoint+1) | otherwise = error "finalWordCentres: input < 0" -{- Outcommented for release 0.2.2.1; gives away what is going to appear in 0.3 -------------------------------------------------------------------------------- longestApproximatePalindromes---------------------------------------------------------------------------------- | longestApproximatePalindromes returns the longest approximate --- palindrome around each position in a string. An approximate palindrome--- is a palindrome with at most a specified number of errors.-longestApproximatePalindromes :: (Eq a,Show a) => Int -> [a] -> String-longestApproximatePalindromes nrOfErrors input = - let inputArray = listArrayl0 input- (maxLength,pos) = (\(((l,nrOfErrors):xs),p) -> (l,p)) $ - maximumBy - (\((l,_):_,_) ((l',_):_,_) -> compare l l') - (zip (approximatePalindromesAroundCentres nrOfErrors inputArray) [0..]) - in showPalindrome inputArray (maxLength,pos)---------------------------------------------------------------------------------- approximatePalindromesAroundCentres ------ This is the function palindromesAroundCentres, but now the palindrome--- may contain a specified number of errors.---------------------------------------------------------------------------------- | for each centre, approximatePalindromesAroundCentres calculates a list --- palindromes with corresponding nrOfErrors, in decreasing length.-approximatePalindromesAroundCentres :: Int -> Array Int a -> [[(Int,Int)]]-approximatePalindromesAroundCentres nrOfErrors inputArray = - let (afirst,_) = bounds inputArray- in reverse $ extendTailWord inputArray afirst (0,[0]) []--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 = - -- reached the end of the text input array - finalWordCentres textInputArray positionArray inputArray currentTail centres (current:centres)- | n-currentTail == afirst = - -- the current longest tail palindrome extends to the start of the text input array- extendWordCentres textInputArray positionArray inputArray n (current:centres) centres currentTail- | (textInputArray!!!n) == (textInputArray!!!(n-currentTail-1)) = - -- the current longest tail palindrome can be extended- -- check whether or not the extended palindrome is a wordpalindrome- if surroundedByPunctuation (positionArray!!!(n-currentTail-1)) (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 = - -- the current longest tail palindrome cannot be extended - 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 = - -- the last centre is on the last element: - -- try to extend the tail of length 1- 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- | centreDistance-1 == fst (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- let (currentTail,oldWord:oldWords) = head tcentres- in if surroundedByPunctuation (positionArray!(n-currentTail)) (positionArray!(n-1)) 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 = - -- move the centres one step- -- add the length of the longest palindrome - -- to the centres- let newTail = min (fst (head tcentres)) (centreDistance-1)- oldWord = head (snd (head tcentres))- newWords = if oldWord < newTail- then if surroundedByPunctuation (positionArray!(n-newTail+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) (centreDistance-1)--finalWordCentres :: Array Int Char -> Array Int Int -> Array Int Char -> Int -> [(Int,[Int])] -> [(Int,[Int])] -> [(Int,[Int])]-finalWordCentres textInputArray positionArray inputArray n tcentres centres - | n == 0 = centres- | n > 0 = let (_,tlast) = bounds textInputArray- (oldTail,oldWord:oldWords) = head tcentres- newTail = min oldTail (n-1)- diff = if oldTail < n-1 then n - 1 - oldTail else 0- firstMirror = min tlast (tlast-diff-newTail+1)- lastMirror = tlast-diff- newWords = if oldWord < newTail - && surroundedByPunctuation (positionArray!firstMirror) (positionArray!lastMirror) inputArray- then newTail:oldWord:oldWords- else if null oldWords then oldWord:oldWords else oldWords- in finalWordCentres textInputArray positionArray inputArray (n-1) (tail tcentres) ((newTail,newWords):centres)- | otherwise = error "finalWordCentres: input < 0" ---}------------------------------------------------------------------------------ -- Showing palindromes and other text related functionality ----------------------------------------------------------------------------- @@ -512,12 +425,13 @@ then a!n else error (show (fst (bounds a)) ++ " " ++ show (snd (bounds a)) ++ " " ++ show n) + {- -- Used for testing purposes. wpac = wordPalindromesAroundCentres lwp = longestWordPalindromes 0-s = "aaaab a" -- "what is non si, not?"-- "www www www www"-- "wwww w woow waw wwwwwww w"+s = "aaaab a" -- "w woow wawaw woow w" -- "what is non si, not?"-- "www www www www"-- "wwww w woow waw wwwwwww w" a = listArrayl0 s i = zip s [0..] t' = map (first toLower) (filter (myIsLetter.fst) i)@@ -531,4 +445,5 @@ ret = reverse $ map (head . snd) $ et zret = zip ret [0..] mzret = maximumBy (\(w,_) (w',_) -> compare w w') zret+ -}
tests/Main.hs view
@@ -1,5 +1,236 @@+-----------------------------------------------------------------------------+-- |+-- Module : tests.Main+-- Copyright : (c) 2007 - 2011 Johan Jeuring+-- License : BSD3+--+-- Maintainer : johan@jeuring.net+-- Stability : experimental+-- Portability : portable+--+-----------------------------------------------------------------------------+ module Main where- ++import Data.Array+import Data.Char++import Test.QuickCheck+import Test.HUnit++import Data.Algorithms.Palindromes.Palindromes++propPalindromesAroundCentres :: Property+propPalindromesAroundCentres = + forAll (arbitrary:: Gen [Int]) $ + \l -> let a = array (0,length l - 1) (zip [0..] l)+ in palindromesAroundCentres a == longestPalindromesQ a++longestPalindromesQ :: Eq a => Array Int a -> [Int]+longestPalindromesQ a = + let (afirst,alast) = bounds a+ positions = [0 .. 2*(alast-afirst+1)]+ in map (lengthPalindromeAround a) positions++lengthPalindromeAround :: Eq a => Array Int a + -> Int + -> Int+lengthPalindromeAround a position + | even position = + extendPalindromeAround (afirst+pos-1) (afirst+pos) + | odd position = + extendPalindromeAround (afirst+pos-1) (afirst+pos+1) + where pos = div position 2+ (afirst,alast) = bounds a+ extendPalindromeAround start end = + if start < 0 + || end > alast-afirst + || a!start /= a!end+ then end-start-1+ else extendPalindromeAround (start-1) (end+1) ++propTextPalindrome :: Property+propTextPalindrome =+ forAll (arbitrary:: Gen [Char]) $ + \l -> let ltp = longestTextPalindrome l+ ltp' = map toLower (filter isLetter (unescape ltp))+ in ltp' == reverse ltp'++unescape :: String -> String+unescape [] = []+unescape cs = case readLitChar cs of+ (c,rest):xs -> c:unescape rest+ [] -> [] ++testTextPalindrome1, testTextPalindrome2, testTextPalindrome3, testTextPalindrome4, + testTextPalindrome5, testTextPalindrome6, testTextPalindrome7, testTextPalindrome8,+ testTextPalindrome9, testTextPalindrome10, testTextPalindrome11 :: Test++testWordPalindrome1, testWordPalindrome2, testWordPalindrome3, testWordPalindrome4,+ testWordPalindrome5, testWordPalindrome6 :: Test++testTextPalindrome1 =+ TestCase (assertEqual + "textPalindrome1" + "\"a,ba.\"" + (longestTextPalindrome "abcdea,ba.")+ )+testTextPalindrome2 =+ TestCase (assertEqual + "textPalindrome2" + "\"a,ba\"" + (longestTextPalindrome "abcdea,ba")+ )+testTextPalindrome3 =+ TestCase (assertEqual + "textPalindrome3" + "\".a,ba\"" + (longestTextPalindrome "abcde.a,ba")+ )+testTextPalindrome4 =+ TestCase (assertEqual + "textPalindrome4" + "\".a,ba\"" + (longestTextPalindrome "abcde.a,baf")+ )+testTextPalindrome5 =+ TestCase (assertEqual + "textPalindrome5" + "\".ab,a\"" + (longestTextPalindrome ".ab,acdef")+ )+testTextPalindrome6 =+ TestCase (assertEqual + "textPalindrome6" + "\"ab,a\"" + (longestTextPalindrome "ab,acdef")+ )+testTextPalindrome7 =+ TestCase (assertEqual + "textPalindrome7" + "\"ab,a.\"" + (longestTextPalindrome "ab,a.cdef")+ )+testTextPalindrome8 =+ TestCase (assertEqual + "textPalindrome8" + "\".ab,a.\"" + (longestTextPalindrome "g.ab,a.cdef")+ )+testTextPalindrome9 =+ TestCase (assertEqual + "textPalindrome9" + "" + (longestTextPalindrome "")+ )++testTextPalindrome10 =+ TestCase (do string <- readFile "examples/palindromes/Damnitimmad.txt"+ assertEqual + "textPalindrome10" + (concatMap (\c -> case c of+ '\n' -> "\\n" + '\"' -> "\\\""+ d -> [d]+ )+ string+ )+ (init . tail $ longestTextPalindrome string)+ )++testTextPalindrome11 =+ TestCase (do string <- readFile "examples/palindromes/pal17.txt"+ assertEqual + "textPalindrome11" + ("\"" ++ + concatMap (\c -> case c of+ '\n' -> "\\n" + '\"' -> "\\\""+ d -> [d]+ )+ string ++ + "\"")+ (longestTextPalindrome string)+ )++testWordPalindrome1 =+ TestCase (assertEqual+ "wordPalindrome" + "\" is non si, \"" + (longestWordPalindrome "what is non si, not?")+ )++testWordPalindrome2 =+ TestCase (assertEqual+ "wordPalindrome" + "\" is non si\"" + (longestWordPalindrome "what is non si")+ )++testWordPalindrome3 =+ TestCase (assertEqual+ "wordPalindrome" + "\"is non si, \"" + (longestWordPalindrome "is non si, not?")+ )++testWordPalindrome4 =+ TestCase (assertEqual+ "wordPalindrome" + "" + (longestWordPalindrome "aaaaba")+ )++testWordPalindrome5 =+ TestCase (assertEqual+ "wordPalindrome" + "\" a\"" + (longestWordPalindrome "aaaab a")+ )++testWordPalindrome6 =+ TestCase (assertEqual+ "wordPalindrome" + "\" waaw \"" + (longestWordPalindrome "w waaw wo waw")+ )++tests :: Test+tests = TestList [TestLabel "testTextPalindrome1" testTextPalindrome1+ ,TestLabel "testTextPalindrome2" testTextPalindrome2+ ,TestLabel "testTextPalindrome3" testTextPalindrome3+ ,TestLabel "testTextPalindrome4" testTextPalindrome4+ ,TestLabel "testTextPalindrome5" testTextPalindrome5+ ,TestLabel "testTextPalindrome6" testTextPalindrome6+ ,TestLabel "testTextPalindrome7" testTextPalindrome7+ ,TestLabel "testTextPalindrome8" testTextPalindrome8+ ,TestLabel "testTextPalindrome9" testTextPalindrome9+ ,TestLabel "testTextPalindrome10" testTextPalindrome10+ ,TestLabel "testTextPalindrome11" testTextPalindrome11+ ,TestLabel "testWordPalindrome1" testWordPalindrome1+ ,TestLabel "testWordPalindrome2" testWordPalindrome2+ ,TestLabel "testWordPalindrome3" testWordPalindrome3+ ,TestLabel "testWordPalindrome4" testWordPalindrome4+ ,TestLabel "testWordPalindrome5" testWordPalindrome5+ ,TestLabel "testWordPalindrome6" testWordPalindrome6+ ]++main :: IO Counts+main = do + quickCheck propPalindromesAroundCentres+ quickCheck propTextPalindrome+ runTestTT tests+ ++{- +Code for benchmarking. Needs to go in a separate file.++To compare my solution and Rampion's lazy solution:++ [bench "lengthLongestPalindromes" (nf (palindromesAroundCentres (==) . listArrayl0) input)+ ,bench "Rampion's solution" (nf maximalPalindromeLengths input)+ ]+ import Criterion.Main import Data.Algorithms.Palindromes.Palindromes import PalindromeRampion@@ -12,11 +243,5 @@ input <- hGetContents fn defaultMain [bench "lengthLongestPalindrome-Eq" (nf lengthLongestPalindrome input)] --{- To compare my solution and Rampion's lazy solution:-- [bench "lengthLongestPalindromes" (nf (palindromesAroundCentres (==) . listArrayl0) input)- ,bench "Rampion's solution" (nf maximalPalindromeLengths input)- ] -}