diff --git a/CREDITS b/CREDITS --- a/CREDITS +++ b/CREDITS @@ -5,7 +5,18 @@ This is a list of those who have contributed to the research, concept, code, and/or other issues of Finding Palindromes. +Research and code +----------------- + * Johan Jeuring +* Bastiaan Heeren developed an implementation of palindromes + using suffix trees. This version was slower, and could + process less data than this released version. +Bug reports and feature requests +-------------------------------- + +* Rafael Cunha de Almeida +* Henning Thielemann diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2007 - 2009 Johan Jeuring +Copyright (c) 2007 - 2010 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 @@ -16,6 +16,8 @@ * Linear-time algorithm for finding text palindromes, ignoring spaces, case of characters, and punctuation symbols. +* Linear-time algorithm for finding word palindromes, + text palindromes surrounded by (if at all) non-letters. Requirements diff --git a/RELEASE_HISTORY b/RELEASE_HISTORY new file mode 100644 --- /dev/null +++ b/RELEASE_HISTORY @@ -0,0 +1,15 @@ +Release history: + +Version 2 +Read from standard input, via the flag -i +More flexible flag handling +Read multiple files +Specify minimum length of palindromes returned, via the flag -m int + +070909 Version 0.1.1 +Corrected two errors in the flags + +060909 Version 0.1 +First version of the package + + diff --git a/palindromes.cabal b/palindromes.cabal --- a/palindromes.cabal +++ b/palindromes.cabal @@ -1,14 +1,14 @@ name: palindromes -version: 0.1.1 +version: 0.2 synopsis: Finding palindromes in strings homepage: http://www.jeuring.net/Palindromes description: - FindingPalindromes is an executable and a library which takes a file name, and + palindromes is an executable and a library which takes a file name, and returns information about palindromes in the file. category: Algorithms -copyright: (c) 2007 - 2009 Johan Jeuring +copyright: (c) 2007 - 2010 Johan Jeuring license: BSD3 license-file: LICENSE author: Johan Jeuring @@ -16,6 +16,7 @@ stability: experimental extra-source-files: README, CREDITS, + RELEASE_HISTORY tests/Main.hs build-type: Simple cabal-version: >= 1.2.1 @@ -31,12 +32,10 @@ Main-is: Data/Algorithms/Palindromes/Main.hs ghc-options: -Wall hs-source-dirs: src - other-modules: Data.Algorithms.Palindromes.Palindromes - - + other-modules: Data.Algorithms.Palindromes.Palindromes, + Data.Algorithms.Palindromes.Options build-depends: base >= 3.0 && < 4.0, array - -------------------------------------------------------------------------------- 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 @@ -1,54 +1,49 @@ ----------------------------------------------------------------------------- -- | -- Module : Data.Algorithms.Palindromes.Main --- Copyright : (c) 2007 - 2009 Johan Jeuring +-- Copyright : (c) 2007 - 2010 Johan Jeuring -- License : BSD3 -- -- Maintainer : johan@jeuring.net -- Stability : experimental --- Portability : non-portable +-- Portability : portable -- ----------------------------------------------------------------------------- module Main where import System.Environment (getArgs) -import System.IO +import System.Console.GetOpt +import System.IO -import Data.Algorithms.Palindromes.Palindromes +import Data.Algorithms.Palindromes.Options -helpMessage :: String -helpMessage = - "Usage:\n\n" - ++ " palindrome [command-line-options] input-file\n\n" - ++ "The following options are available:\n" - ++ " --h: This message\n" - ++ " -p : Print the longest palindrome (default)\n" - ++ " -ps: Print the longest palindrome around each position in the input\n" - ++ " -l : Print the length of the longest palindrome\n" - ++ " -ls: Print the length of the longest palindrome around each position in the input\n" - ++ " -t : Print the longest palindrome ignoring case, spacing and punctuation\n" - ++ " -ts: Print the length of the longest text palindrome\n" - +----------------------------------------------------------------------------- +-- main +----------------------------------------------------------------------------- + +handleFilesWith :: (String -> String) -> [String] -> IO () +handleFilesWith f = + let hFW filenames = + case filenames of + [] -> putStr (f "") + (fn:fns) -> do input <- readFile fn + putStrLn (f input) + hFW fns + in hFW + +handleStandardInputWith :: (String -> String) -> IO () +handleStandardInputWith function = + do input <- getContents + putStrLn (function input) + main :: IO () -main = do - putStrLn "*********************" - putStrLn "* Palindrome Finder *" - putStrLn "*********************" - args <- getArgs - case args of - ['-':flag,filePath] -> do let function = - case flag of - "p" -> longestPalindrome - "ps" -> longestPalindromes - "l" -> lengthLongestPalindrome - "ls" -> lengthLongestPalindromes - "t" -> longestTextPalindrome - "ts" -> longestTextPalindromes - _ -> const helpMessage - input <- readFile filePath - putStrLn (function input) - [arg] -> do case arg of - '-':_ -> putStrLn helpMessage - _ -> do input <- readFile arg - putStrLn (longestPalindrome input) - _ -> putStrLn helpMessage +main = do args <- getArgs + let (optionArgs,files,errors) = getOpt Permute options args + if not (null errors) + then putStrLn (concat errors) + else let (function,fromfile) = handleOptions optionArgs + in if fromfile + then handleFilesWith function files + else handleStandardInputWith function + + diff --git a/src/Data/Algorithms/Palindromes/Options.hs b/src/Data/Algorithms/Palindromes/Options.hs new file mode 100644 --- /dev/null +++ b/src/Data/Algorithms/Palindromes/Options.hs @@ -0,0 +1,113 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Data.Algorithms.Palindromes.Options +-- Copyright : (c) 2007 - 2010 Johan Jeuring +-- License : BSD3 +-- +-- Maintainer : johan@jeuring.net +-- Stability : experimental +-- Portability : portable +-- +----------------------------------------------------------------------------- +module Data.Algorithms.Palindromes.Options where + +import System.Console.GetOpt + +import Data.Algorithms.Palindromes.Palindromes + +----------------------------------------------------------------------------- +-- flags +----------------------------------------------------------------------------- + +data Flag = Help + | StandardInput + | LongestPalindrome + | LongestPalindromes + | LengthLongestPalindrome + | LengthLongestPalindromes + | LongestTextPalindrome + | LongestTextPalindromes + | LongestWordPalindrome + | LongestWordPalindromes + | LengthAtLeast Int deriving Show + + +isHelp :: Flag -> Bool +isHelp Help = True +isHelp _ = False + +isStandardInput :: Flag -> Bool +isStandardInput StandardInput = True +isStandardInput _ = False + +isLengthAtLeast :: Flag -> Bool +isLengthAtLeast (LengthAtLeast _) = True +isLengthAtLeast _ = False + +getLength :: Flag -> Int +getLength (LengthAtLeast n) = n +getLength _ = error "No length specified" + +-- I am using single letter options here (except for help): getOpt handles +-- options too flexible: in case a letter within a multiple letter option is +-- recognized, it is taken as a single letter option. +options :: [OptDescr Flag] +options = + [Option "h" ["help"] (NoArg Help) + "This message" + ,Option "i" [] (NoArg StandardInput) + "Read input from standard input" + ,Option "o" [] (NoArg LongestPalindrome) + "Longest palindrome (default)" + ,Option "p" [] (NoArg LongestPalindromes) + "Longest palindrome around each position in the input" + ,Option "k" [] (NoArg LengthLongestPalindrome) + "Length of the longest palindrome" + ,Option "l" [] (NoArg LengthLongestPalindromes) + "Length of the longest palindrome around each position in the input" + ,Option "s" [] (NoArg LongestTextPalindrome) + "Longest palindrome ignoring case, spacing and punctuation" + ,Option "t" [] (NoArg LongestTextPalindromes) + "Longest text palindrome around each position in the input" + ,Option "v" [] (NoArg LongestWordPalindrome) + "Longest text palindrome preceded and followed by punctuation symbols (if any)" + ,Option "w" [] (NoArg LongestWordPalindromes) + "Longest word palindrome around each position in the input" + ,Option "m" [] (ReqArg (LengthAtLeast . (read :: String -> Int)) "arg") + "Palindromes of length at least [arg]" + ] + +handleOptions :: [Flag] -> (String -> String,Bool) +handleOptions flags = + let lal = filter isLengthAtLeast flags + flags' = filter (\f -> not (isLengthAtLeast f || isStandardInput f)) flags + m = if null lal + then 0 + else getLength (head lal) + fromfile = null $ filter isStandardInput flags + function = case flags' of + [] -> longestPalindrome + (flag:_) -> + case flag of + Help -> + const (usageInfo headerHelpMessage options) + LongestPalindrome -> longestPalindrome + LongestPalindromes -> longestPalindromes m + LengthLongestPalindrome -> lengthLongestPalindrome + LengthLongestPalindromes -> lengthLongestPalindromes + LongestTextPalindrome -> longestTextPalindrome + LongestTextPalindromes -> longestTextPalindromes m + LongestWordPalindrome -> longestWordPalindrome + LongestWordPalindromes -> longestWordPalindromes m + _ -> error "handleOptions" + in (function,fromfile) + +headerHelpMessage :: String +headerHelpMessage = + "*********************\n" + ++ "* Palindrome Finder *\n" + ++ "*********************\n" + ++ "Usage:" + + + 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,12 +1,12 @@ ----------------------------------------------------------------------------- -- | -- Module : Data.Algorithms.Palindromes.Palindromes --- Copyright : (c) 2007 - 2009 Johan Jeuring +-- Copyright : (c) 2007 - 2010 Johan Jeuring -- License : BSD3 -- -- Maintainer : johan@jeuring.net -- Stability : experimental --- Portability : portable (requires ghc) +-- Portability : portable -- ----------------------------------------------------------------------------- @@ -17,15 +17,17 @@ ,lengthLongestPalindromes ,longestTextPalindrome ,longestTextPalindromes + ,longestWordPalindrome + ,longestWordPalindromes ,palindromesAroundCentres ) where -import Debug.Trace() - import Data.List (maximumBy,intersperse) import Data.Char import Data.Array +import Control.Arrow + -- All functions in the interface, except palindromesAroundCentres -- have the type String -> String @@ -36,7 +38,7 @@ -- | longestPalindrome returns the longest palindrome in a string. longestPalindrome :: String -> String longestPalindrome input = - let inputArray = stringArray input + let inputArray = listArrayl0 input (maxLength,pos) = maximumBy (\(l,_) (l',_) -> compare l l') (zip (palindromesAroundCentres inputArray) [0..]) @@ -47,13 +49,15 @@ ----------------------------------------------------------------------------- -- | longestPalindromes returns the longest palindrome around each position --- in a string. -longestPalindromes :: String -> String -longestPalindromes input = - let inputArray = stringArray input +-- in a string. The integer argument is used to only show palindromes +-- of length at least this integer. +longestPalindromes :: Int -> String -> String +longestPalindromes m input = + let inputArray = listArrayl0 input in concat $ intersperse "\n" $ map (showPalindrome inputArray) + $ filter ((m<=) . fst) $ zip (palindromesAroundCentres inputArray) [0..] ----------------------------------------------------------------------------- @@ -64,7 +68,7 @@ -- a string. lengthLongestPalindrome :: String -> String lengthLongestPalindrome = - show . maximum . palindromesAroundCentres . stringArray + show . maximum . palindromesAroundCentres . listArrayl0 ----------------------------------------------------------------------------- -- lengthLongestPalindromes @@ -74,7 +78,7 @@ -- around each position in a string. lengthLongestPalindromes :: String -> String lengthLongestPalindromes = - show . palindromesAroundCentres . stringArray + show . palindromesAroundCentres . listArrayl0 ----------------------------------------------------------------------------- -- longestTextPalindrome @@ -84,13 +88,12 @@ -- ignoring spacing, punctuation symbols, and case of letters. longestTextPalindrome :: String -> String longestTextPalindrome input = - let inputArray = stringArray input + let inputArray = listArrayl0 input ips = zip input [0..] - textinput = map (\(i,p) -> (toLower i,p)) + textinput = map (first toLower) (filter (isLetter.fst) ips) - textInputArray = stringArray (map fst textinput) - lti = length textinput - positionTextInputArray = listArray (0,lti-1) (map snd textinput) + textInputArray = listArrayl0 (map fst textinput) + positionTextInputArray = listArrayl0 (map snd textinput) in longestTextPalindromeArray textInputArray positionTextInputArray @@ -109,30 +112,115 @@ ----------------------------------------------------------------------------- -- | longestTextPalindromes returns the longest text palindrome around each --- position in a string. -longestTextPalindromes :: String -> String -longestTextPalindromes input = - let inputArray = stringArray input +-- position in a string. The integer argument is used to only show palindromes +-- of length at least this integer. +longestTextPalindromes :: Int -> String -> String +longestTextPalindromes m input = + let inputArray = listArrayl0 input ips = zip input [0..] - textinput = map (\(i,p) -> (toLower i,p)) + textinput = map (first toLower) (filter (isLetter.fst) ips) - textInputArray = stringArray (map fst textinput) - lti = length textinput - positionTextInputArray = listArray (0,lti-1) (map snd textinput) + textInputArray = listArrayl0 (map fst textinput) + positionTextInputArray = listArrayl0 (map snd textinput) in concat $ intersperse "\n" $ longestTextPalindromesArray + m 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..]) + (Show a, Eq a) => + Int -> Array Int a -> Array Int Int -> Array Int a -> [String] +longestTextPalindromesArray m a positionArray inputArray = + map (showTextPalindrome positionArray inputArray) + $ filter ((m<=) . fst) + $ zip (palindromesAroundCentres a) [0..] ----------------------------------------------------------------------------- +-- longestWordPalindrome +----------------------------------------------------------------------------- + +-- | 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 (isLetter.fst) ips) + textInputArray = listArrayl0 (map fst textinput) + positionTextInputArray = listArrayl0 (map snd textinput) + in longestWordPalindromeArray + textInputArray + positionTextInputArray + inputArray + +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 + +----------------------------------------------------------------------------- +-- longestWordPalindromes +----------------------------------------------------------------------------- + +-- | longestWordPalindromes returns the longest word palindrome around each +-- position in a string. The integer argument is used to only show +-- palindromes of length at least this integer. +longestWordPalindromes :: Int -> String -> String +longestWordPalindromes m input = + let inputArray = listArrayl0 input + ips = zip input [0..] + textinput = map (first toLower) + (filter (isLetter.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 a positionArray inputArray = + map (showTextPalindrome positionArray inputArray) + $ filter ((m<=) . fst) + $ filter (isWordpalindrome positionArray inputArray) + $ zip (palindromesAroundCentres a) [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 (isLetter (inputArray!!!(endpos'+1))) + else if endpos' >= snd (bounds inputArray) + then not (isLetter (inputArray!!!(startpos'-1))) + else not (isLetter (inputArray!!!(startpos'-1))) + && not (isLetter (inputArray!!!(endpos'+1))) + +----------------------------------------------------------------------------- -- palindromesAroundCentres -- -- The function that implements the palindrome finding algorithm. @@ -171,7 +259,6 @@ centres currentTail where (afirst,alast) = bounds a - extendCentres :: (Eq a) => Array Int a -> Int -> [Int] -> [Int] -> Int -> [Int] extendCentres a n centres tcentres centreDistance @@ -203,7 +290,7 @@ finalCentres _ _ _ = error "finalCentres: input < 0" ----------------------------------------------------------------------------- --- Showing palindreoms +-- Showing palindromes ----------------------------------------------------------------------------- showPalindrome :: (Show a) => Array Int a -> (Int,Int) -> String @@ -212,7 +299,7 @@ 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]] + in show [a!n|n <- [startpos .. endpos]] showTextPalindrome :: (Show a) => Array Int Int -> Array Int a -> (Int,Int) -> String @@ -229,29 +316,18 @@ end = if endpos < snd (bounds positionArray) then positionArray!!!(endpos+1)-1 else snd (bounds inputArray) - in show $ [inputArray!n | n<- [start..end]] + in show [inputArray!n | n<- [start..end]] ----------------------------------------------------------------------------- -- Array utils ----------------------------------------------------------------------------- -stringArray :: String -> Array Int Char -stringArray string = listArray (0,length string - 1) string +listArrayl0 :: [a] -> Array Int a +listArrayl0 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) - - - - - - - - - - - + else error (show (fst (bounds a)) ++ " " ++ show (snd (bounds a)) ++ " " ++ show n) diff --git a/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -1,3 +1,15 @@ +----------------------------------------------------------------------------- +-- | +-- 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 @@ -131,6 +143,48 @@ (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" + "\" waw\"" + (longestWordPalindrome "w waaw wo waw") + ) + tests = TestList [TestLabel "testTextPalindrome1" testTextPalindrome1 ,TestLabel "testTextPalindrome2" testTextPalindrome2 ,TestLabel "testTextPalindrome3" testTextPalindrome3 @@ -142,6 +196,12 @@ ,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 = do