diff --git a/RELEASE_HISTORY b/RELEASE_HISTORY --- a/RELEASE_HISTORY +++ b/RELEASE_HISTORY @@ -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 diff --git a/palindromes.cabal b/palindromes.cabal --- a/palindromes.cabal +++ b/palindromes.cabal @@ -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: diff --git a/src/Data/Algorithms/Palindromes/Palindromes.hs b/src/Data/Algorithms/Palindromes/Palindromes.hs --- a/src/Data/Algorithms/Palindromes/Palindromes.hs +++ b/src/Data/Algorithms/Palindromes/Palindromes.hs @@ -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 + -} diff --git a/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -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) - ] -}