diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2007 - 2010 Johan Jeuring +Copyright (c) 2007 - 2012 Johan Jeuring All rights reserved. Redistribution and use in source and binary forms, with or without modification, diff --git a/README b/README --- a/README +++ b/README @@ -25,9 +25,9 @@ Palindromes has the following requirements: -* [GHC] version 6.8.1 or later - It has been tested with version 6.10.1. +* [GHC] version 6.8.1 or later - It has been tested with version 7.0.4. * [Cabal] library version 1.2.1 or later - It has been tested with version - 1.6.0.1. + 1.10.2.0. [GHC]: http://www.haskell.org/ghc/ [Cabal]: http://www.haskell.org/cabal/ diff --git a/RELEASE_HISTORY b/RELEASE_HISTORY --- a/RELEASE_HISTORY +++ b/RELEASE_HISTORY @@ -1,6 +1,13 @@ Release history: -100110 Version 2 +170312 Version 0.2.2 +Corrected the word palindromes solution + +261211 Version 0.2.1 +Updated base dependency from <=4 to <5 +Used latin1 character set for input files + +100110 Version 0.2 Read from standard input, via the flag -i More flexible flag handling Read multiple files diff --git a/palindromes.cabal b/palindromes.cabal --- a/palindromes.cabal +++ b/palindromes.cabal @@ -1,5 +1,5 @@ name: palindromes -version: 0.2.1 +version: 0.2.2 synopsis: Finding palindromes in strings homepage: http://www.jeuring.net/Palindromes description: diff --git a/src/Data/Algorithms/Palindromes/Main.hs b/src/Data/Algorithms/Palindromes/Main.hs --- a/src/Data/Algorithms/Palindromes/Main.hs +++ b/src/Data/Algorithms/Palindromes/Main.hs @@ -26,12 +26,11 @@ let hFW filenames = case filenames of [] -> putStr (f "") - (fn:fns) -> do -- input <- readFile fn - fn' <- openFile fn ReadMode - hSetEncoding fn' latin1 - input <- hGetContents fn' - putStrLn (f input) - hFW fns + (fn:fns) -> do fn' <- openFile fn ReadMode + hSetEncoding fn' latin1 + input <- hGetContents fn' + putStrLn (f input) + hFW fns in hFW handleStandardInputWith :: (String -> String) -> IO () diff --git a/src/Data/Algorithms/Palindromes/Options.hs b/src/Data/Algorithms/Palindromes/Options.hs --- a/src/Data/Algorithms/Palindromes/Options.hs +++ b/src/Data/Algorithms/Palindromes/Options.hs @@ -91,15 +91,15 @@ case flag of Help -> const (usageInfo headerHelpMessage options) - LongestPalindrome -> longestPalindrome + LongestPalindrome -> longestPalindrome LongestPalindromes -> longestPalindromes m - LengthLongestPalindrome -> lengthLongestPalindrome + LengthLongestPalindrome -> lengthLongestPalindrome LengthLongestPalindromes -> lengthLongestPalindromes LongestTextPalindrome -> longestTextPalindrome LongestTextPalindromes -> longestTextPalindromes m LongestWordPalindrome -> longestWordPalindrome - LongestWordPalindromes -> longestWordPalindromes m - _ -> error "handleOptions" + LongestWordPalindromes -> longestWordPalindromes m + _ -> error "handleOptions" in (function,fromfile) headerHelpMessage :: String 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 @@ -1,7 +1,15 @@ +-- palindromesAroundCentres +-- palindromeWordsAroundCentres +-- approximatePalindromesAroundCentres +-- are the central functions of this module +-- approximatePalindromesAroundCentres is easily defined in the style of +-- the others. +-- Use the text-based palindrome finding, and check for each addition whether or not it is a wordpalindrome + ----------------------------------------------------------------------------- -- | -- Module : Data.Algorithms.Palindromes.Palindromes --- Copyright : (c) 2007 - 2010 Johan Jeuring +-- Copyright : (c) 2007 - 2012 Johan Jeuring -- License : BSD3 -- -- Maintainer : johan@jeuring.net @@ -10,7 +18,7 @@ -- ----------------------------------------------------------------------------- -module Data.Algorithms.Palindromes.Palindromes +module Data.Algorithms.Palindromes.Palindromes (longestPalindrome ,longestPalindromes ,lengthLongestPalindrome @@ -20,23 +28,22 @@ ,longestWordPalindrome ,longestWordPalindromes ,palindromesAroundCentres - ) where + ,listArrayl0 + ) where import Data.List (maximumBy,intersperse) -import Data.Char -import Data.Array +import Data.Char(toLower,isPunctuation,isSpace,isControl) +import Data.Array(Array(),bounds,listArray,(!)) +-- import Debug.Trace import Control.Arrow - --- 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 :: (Eq a,Show a) => [a] -> String longestPalindrome input = let inputArray = listArrayl0 input (maxLength,pos) = maximumBy @@ -51,7 +58,7 @@ -- | longestPalindromes returns the longest palindrome around each position -- in a string. The integer argument is used to only show palindromes -- of length at least this integer. -longestPalindromes :: Int -> String -> String +longestPalindromes :: (Eq a,Show a) => Int -> [a] -> String longestPalindromes m input = let inputArray = listArrayl0 input in concat @@ -66,7 +73,7 @@ -- | lengthLongestPalindrome returns the length of the longest palindrome in -- a string. -lengthLongestPalindrome :: String -> String +lengthLongestPalindrome :: Eq a => [a] -> String lengthLongestPalindrome = show . maximum . palindromesAroundCentres . listArrayl0 @@ -76,7 +83,7 @@ -- | lengthLongestPalindromes returns the lengths of the longest palindrome -- around each position in a string. -lengthLongestPalindromes :: String -> String +lengthLongestPalindromes :: Eq a => [a] -> String lengthLongestPalindromes = show . palindromesAroundCentres . listArrayl0 @@ -100,7 +107,7 @@ inputArray longestTextPalindromeArray :: - (Show a, Eq a) => Array Int a -> Array Int Int -> Array Int a -> String + Array Int Char -> Array Int Int -> Array Int Char -> String longestTextPalindromeArray a positionArray inputArray = let (len,pos) = maximumBy (\(l,_) (l',_) -> compare l l') @@ -124,53 +131,80 @@ positionTextInputArray = listArrayl0 (map snd textinput) in concat $ intersperse "\n" - $ longestTextPalindromesArray + $ longestTextPalindromesArray m textInputArray positionTextInputArray inputArray longestTextPalindromesArray :: - (Show a, Eq a) => - Int -> Array Int a -> Array Int Int -> Array Int a -> [String] + 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..] +-- introduce == only here (not in longestTextPalindromes)? + ----------------------------------------------------------------------------- --- longestWordPalindrome +-- palindromesAroundCentres +-- +-- The function that implements the palindrome finding algorithm. +-- Used in all the above interface functions. ----------------------------------------------------------------------------- --- | longestWordPalindrome returns the longest text palindrome preceded and --- followed by punctuation symbols (if any). Note that if a word palindrome is --- accidentally surrounded by the same symbols, it won't be found. For --- example, the longest word palindrome in "w waaw wo waw" is "waw". We could --- change longestWordPalindrome to return the longest enclosed word --- palindrome, but that would give a quadratic time algorithm. -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) - positionTextInputArray = listArrayl0 (map snd textinput) - in longestWordPalindromeArray - textInputArray - positionTextInputArray - inputArray +-- | 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 [] -longestWordPalindromeArray :: - Array Int Char -> Array Int Int -> Array Int Char -> String -longestWordPalindromeArray a positionArray inputArray = - let wordPalindromes = filter (isWordpalindrome positionArray inputArray) - $ zip (palindromesAroundCentres a) [0..] - in if null wordPalindromes - then "" - else showTextPalindrome positionArray inputArray $ - maximumBy (\(l,_) (l',_) -> compare l l') wordPalindromes +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 n tcentres centres + | n == 0 = centres + | n > 0 = finalCentres (n-1) (tail tcentres) (min (head tcentres) (n-1):centres) + | otherwise = error "finalCentres: input < 0" + ----------------------------------------------------------------------------- -- longestWordPalindromes ----------------------------------------------------------------------------- @@ -188,109 +222,134 @@ positionTextInputArray = listArrayl0 (map snd textinput) in concat $ intersperse "\n" - $ longestWordPalindromesArray + $ longestWordPalindromesArray m textInputArray positionTextInputArray inputArray -longestWordPalindromesArray :: - Int -> Array Int Char -> Array Int Int -> Array Int Char -> [String] -longestWordPalindromesArray m a positionArray 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) - $ filter (isWordpalindrome positionArray inputArray) - $ zip (palindromesAroundCentres a) [0..] + $ zip (wordPalindromesAroundCentres textInputArray positionArray inputArray) [0..] -isWordpalindrome :: Array Int Int -> Array Int Char -> (Int,Int) -> Bool -isWordpalindrome 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 - startpos' = positionArray!!!startpos - endpos' = positionArray!!!endpos - in if endpos < startpos - then False - else if startpos' <= fst (bounds inputArray) - then endpos' >= snd (bounds inputArray) || - not (myIsLetter (inputArray!!!(endpos'+1))) - else if endpos' >= snd (bounds inputArray) - then not (myIsLetter (inputArray!!!(startpos'-1))) - else not (myIsLetter (inputArray!!!(startpos'-1))) - && not (myIsLetter (inputArray!!!(endpos'+1))) +-- | longestWordPalindrome returns the longest text palindrome preceded and +-- followed by non-letter symbols (if any). +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) ----------------------------------------------------------------------------- --- palindromesAroundCentres +-- wordPalindromesAroundCentres -- --- The function that implements the palindrome finding algorithm. --- Used in all the interface functions. +-- This is the function palindromesAroundCentres, extended with the longest +-- word palindromes around each centre. ----------------------------------------------------------------------------- --- | 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 [] +-- | wordPalindromesAroundCentres returns the same lengths of palindromes as +-- palindromesAroundCentres, but at the same time also the length of the +-- longest word palindromes around the centres. +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]) [] -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 +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 + -- trace ("ETW 1 " ++ show current ++ " " ++ "\n") $ + 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 + -- 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 -- 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 + extendWordCentres textInputArray positionArray inputArray n (current:centres) centres currentTail + where (afirst,alast) = bounds textInputArray -extendCentres :: (Eq a) => - Array Int a -> Int -> [Int] -> [Int] -> Int -> [Int] -extendCentres a n centres tcentres centreDistance +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 - extendTail a (n+1) 1 centres - | centreDistance-1 == head tcentres = + if surroundedByPunctuation (positionArray!n) (positionArray!n) inputArray + 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 -- tail palindrome use the mirror property -- of palindromes to find the longest tail -- palindrome - extendTail a n (head tcentres) centres + let (currentTail,oldWord:oldWords) = head tcentres + in if surroundedByPunctuation (positionArray!(n-currentTail)) (positionArray!(n-1)) inputArray + then if oldWord == currentTail + 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 -- 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 -- to the centres - extendCentres a n (min (head tcentres) - (centreDistance-1):centres) - (tail tcentres) (centreDistance-1) + 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 -- trace ("EWC 7 " ++ show (newTail,newWords) ++ " " ++ "\n") $ + extendWordCentres textInputArray positionArray inputArray n ((newTail,newWords):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" +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 -- trace ("FWC 1 " ++ show (newTail,newWords) ++ show (tlast-diff) ++ " " ++ show (tlast-diff-newTail+1) ++ " " ++ show diff ++ show (newTail,newWords) ++ "\n") $ + finalWordCentres textInputArray positionArray inputArray (n-1) (tail tcentres) ((newTail,newWords):centres) + | otherwise = error "finalWordCentres: input < 0" ----------------------------------------------------------------------------- --- Showing palindromes +-- Showing palindromes and other text related functionality ----------------------------------------------------------------------------- showPalindrome :: (Show a) => Array Int a -> (Int,Int) -> String @@ -308,23 +367,41 @@ 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 > 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) + else let start = if startpos > pfirst + then (positionArray!(startpos-1))+1 + else ifirst + end = if endpos < plast + then (positionArray!(endpos+1))-1 + else ilast in show [inputArray!n | n<- [start..end]] ------------------------------------------------------------------------------ --- Character utils ------------------------------------------------------------------------------ +{- Using this code instead of the last else above shows text palindromes without + all punctuation around it. Right now this punctuation is shown. -myIsLetter :: Char -> Bool -myIsLetter = not . flip elem ",.;:!?`~/<> \a\b\f\n\r\t\v\\\"\'\&" + else let start = positionArray!!!startpos + end = positionArray!!!endpos +-} +-- For palindromes in strings, punctuation, spacing, and control characters +-- are often ignored +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!(begin-1))) && 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!(begin-1))) + | otherwise = error "surroundedByPunctuation" + where (afirst,alast) = bounds inputArray + ----------------------------------------------------------------------------- -- Array utils ----------------------------------------------------------------------------- @@ -335,6 +412,28 @@ -- (!!!) 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) +a!!! n = -- trace (show n ++ " " ++ show (snd (bounds a))) $ + if n >= fst (bounds a) && n <= snd (bounds a) 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" +a = listArrayl0 s +i = zip s [0..] +t' = map (first toLower) (filter (myIsLetter.fst) i) +t = listArrayl0 (map fst t') +p::Array Int Int +p = listArrayl0 (map snd t') +sbp = surroundedByPunctuation +te = sbp 2 2 a +etw = extendTailWord +et = etw t p a 0 (0,[0]) [] +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,211 +1,22 @@ ------------------------------------------------------------------------------ --- | --- Module : tests.Main --- Copyright : (c) 2007 - 2010 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 Criterion.Main 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 ltp) - in ltp' == reverse ltp' - -instance Arbitrary Char where - arbitrary = choose (minBound::Char,maxBound::Char) - -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") - ) +import PalindromeRampion +import System.IO -testWordPalindrome5 = - TestCase (assertEqual - "wordPalindrome" - "\" a\"" - (longestWordPalindrome "aaaab a") - ) +main :: IO () +main = + do fn <- openFile "../../../TestSources/Bibles/engelskingjames.txt" ReadMode + hSetEncoding fn latin1 + input <- hGetContents fn + defaultMain + [bench "lengthLongestPalindrome-Eq" (nf lengthLongestPalindrome input)] -testWordPalindrome6 = - TestCase (assertEqual - "wordPalindrome" - "\" waw\"" - (longestWordPalindrome "w waaw wo waw") - ) +{- To compare my solution and Rampion's lazy solution: -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 - ] + [bench "lengthLongestPalindromes" (nf (palindromesAroundCentres (==) . listArrayl0) input) + ,bench "Rampion's solution" (nf maximalPalindromeLengths input) + ] -main = do - check defaultConfig propPalindromesAroundCentres - check defaultConfig propTextPalindrome - runTestTT tests - +-}