-----------------------------------------------------------------------------
-- |
-- Module      :  Data.Algorithm.Palindromes.Palindromes
-- Copyright   :  (c) 2007 - 2009 Johan Jeuring
-- License     :  BSD3
--
-- Maintainer  :  johan@jeuring.net
-- Stability   :  experimental
-- Portability :  portable (requires ghc)
--
-----------------------------------------------------------------------------

module Data.Algorithm.Palindromes.Palindromes
       (longestPalindrome
       ,longestPalindromes
       ,lengthLongestPalindrome
       ,lengthLongestPalindromes
       ,longestTextPalindrome
       ,longestTextPalindromes
       ,palindromesAroundCentres
       ) where
 
import Debug.Trace()

import Data.List (maximumBy,intersperse)
import Data.Char
import Data.Array 
 
-- All functions in the interface, except palindromesAroundCentres 
-- have the type String -> String
       
-----------------------------------------------------------------------------
-- longestPalindrome
-----------------------------------------------------------------------------

-- | longestPalindrome returns the longest palindrome in a string.
longestPalindrome :: String -> String
longestPalindrome input = 
  let inputArray       =  stringArray input
      (maxLength,pos)  =  maximumBy 
                            (\(l,_) (l',_) -> compare l l') 
                            (zip (palindromesAroundCentres inputArray) [0..])    
  in showPalindrome inputArray (maxLength,pos)

-----------------------------------------------------------------------------
-- longestPalindromes
-----------------------------------------------------------------------------

-- | longestPalindromes returns the longest palindrome around each position
--   in a string.
longestPalindromes :: String -> String
longestPalindromes input = 
  let inputArray       =  stringArray input
  in    concat 
      $ intersperse "\n" 
      $ map (showPalindrome inputArray) 
      $ zip (palindromesAroundCentres inputArray) [0..]

-----------------------------------------------------------------------------
-- lengthLongestPalindrome
-----------------------------------------------------------------------------

-- | lengthLongestPalindrome returns the length of the longest palindrome in 
--   a string.
lengthLongestPalindrome :: String -> String
lengthLongestPalindrome =
  show . maximum . palindromesAroundCentres . stringArray

-----------------------------------------------------------------------------
-- lengthLongestPalindromes
-----------------------------------------------------------------------------

-- | lengthLongestPalindromes returns the lengths of the longest palindrome  
--   around each position in a string.
lengthLongestPalindromes :: String -> String
lengthLongestPalindromes =
  show . palindromesAroundCentres . stringArray

-----------------------------------------------------------------------------
-- longestTextPalindrome
-----------------------------------------------------------------------------

-- | longestTextPalindrome returns the longest text palindrome in a string,
--   ignoring spacing, punctuation symbols, and case of letters.
longestTextPalindrome :: String -> String
longestTextPalindrome input = 
  let inputArray              =  stringArray input
      ips                     =  zip input [0..]
      textinput               =  map (\(i,p) -> (toLower i,p)) 
                                     (filter (isLetter.fst) ips)
      textInputArray          =  stringArray  (map fst textinput)
      lti                     =  length textinput
      positionTextInputArray  =  listArray (0,lti-1) (map snd textinput)
  in  longestTextPalindromeArray 
        textInputArray 
        positionTextInputArray 
        inputArray

longestTextPalindromeArray :: 
  (Show a, Eq a) => Array Int a -> Array Int Int -> Array Int a -> String
longestTextPalindromeArray a positionArray inputArray = 
  let (len,pos) = maximumBy 
                    (\(l,_) (l',_) -> compare l l') 
                    (zip (palindromesAroundCentres a) [0..])    
  in showTextPalindrome positionArray inputArray (len,pos) 

-----------------------------------------------------------------------------
-- longestTextPalindromes
-----------------------------------------------------------------------------

-- | longestTextPalindromes returns the longest text palindrome around each
--   position in a string.
longestTextPalindromes :: String -> String
longestTextPalindromes input = 
  let inputArray              =  stringArray input
      ips                     =  zip input [0..]
      textinput               =  map (\(i,p) -> (toLower i,p)) 
                                     (filter (isLetter.fst) ips)
      textInputArray          =  stringArray (map fst textinput)
      lti                     =  length textinput
      positionTextInputArray  =  listArray (0,lti-1) (map snd textinput)
  in  concat 
    $ intersperse "\n" 
    $ longestTextPalindromesArray 
        textInputArray 
        positionTextInputArray 
        inputArray

longestTextPalindromesArray :: 
  (Show a, Eq a) => Array Int a -> Array Int Int -> Array Int a -> [String]
longestTextPalindromesArray a positionArray inputArray = 
  map (showTextPalindrome positionArray inputArray) 
      (zip (palindromesAroundCentres a) [0..])  

-----------------------------------------------------------------------------
-- palindromesAroundCentres 
--
-- The function that implements the palindrome finding algorithm.
-- Used in all the interface functions.
-----------------------------------------------------------------------------

-- | palindromesAroundCentres is the central function of the module. It returns
--   the list of lenghths of the longest palindrome around each position in a
--   string.
palindromesAroundCentres    ::  (Eq a) => 
                                Array Int a -> [Int]
palindromesAroundCentres  a =   
  let (afirst,_) = bounds a
  in reverse $ extendTail a afirst 0 []

extendTail :: (Eq a) => 
              Array Int a -> Int -> Int -> [Int] -> [Int]
extendTail a n currentTail centres 
  | n > alast                    =  
      -- reached the end of the array                                     
      finalCentres currentTail centres 
                   (currentTail:centres)
  | n-currentTail == afirst      =  
      -- the current longest tail palindrome 
      -- extends to the start of the array
      extendCentres a n (currentTail:centres) 
                    centres currentTail 
  | a!n == a!(n-currentTail-1)   =  
      -- the current longest tail palindrome 
      -- can be extended
      extendTail a (n+1) (currentTail+2) centres      
  | otherwise                    =  
      -- the current longest tail palindrome 
      -- cannot be extended                 
      extendCentres a n (currentTail:centres) 
                    centres currentTail
  where  (afirst,alast)  =  bounds a


extendCentres :: (Eq a) =>
                 Array Int a -> Int -> [Int] -> [Int] -> Int -> [Int]
extendCentres a n centres tcentres centreDistance
  | centreDistance == 0                =  
      -- the last centre is on the last element: 
      -- try to extend the tail of length 1
      extendTail a (n+1) 1 centres
  | centreDistance-1 == head tcentres  =  
      -- the previous element in the centre list 
      -- reaches exactly to the end of the last 
      -- tail palindrome use the mirror property 
      -- of palindromes to find the longest tail 
      -- palindrome
      extendTail a n (head tcentres) centres
  | otherwise                          =  
      -- move the centres one step
      -- add the length of the longest palindrome 
      -- to the centres
      extendCentres a n (min (head tcentres) 
                    (centreDistance-1):centres) 
                    (tail tcentres) (centreDistance-1)

finalCentres :: Int -> [Int] -> [Int] -> [Int]
finalCentres 0     _        centres  =  centres
finalCentres (n+1) tcentres centres  =  
  finalCentres n 
               (tail tcentres) 
               (min (head tcentres) n:centres)
finalCentres _     _        _        =  error "finalCentres: input < 0"               

-----------------------------------------------------------------------------
-- Showing palindreoms
-----------------------------------------------------------------------------

showPalindrome :: (Show a) => Array Int a -> (Int,Int) -> String
showPalindrome a (len,pos) = 
  let startpos = pos `div` 2 - len `div` 2
      endpos   = if odd len 
                 then pos `div` 2 + len `div` 2 
                 else pos `div` 2 + len `div` 2 - 1
  in show $ [a!n|n <- [startpos .. endpos]]

showTextPalindrome :: (Show a) => 
                      Array Int Int -> Array Int a -> (Int,Int) -> String
showTextPalindrome positionArray inputArray (len,pos) = 
  let startpos   =  pos `div` 2 - len `div` 2
      endpos     =  if odd len 
                    then pos `div` 2 + len `div` 2 
                    else pos `div` 2 + len `div` 2 - 1
  in  if endpos < startpos
      then []
      else let start      =  if startpos > fst (bounds positionArray)
                             then positionArray!!!(startpos-1)+1
                             else fst (bounds inputArray)
               end        =  if endpos < snd (bounds positionArray)
                             then positionArray!!!(endpos+1)-1
                             else snd (bounds inputArray) 
           in  show $ [inputArray!n | n<- [start..end]]

-----------------------------------------------------------------------------
-- Array utils
-----------------------------------------------------------------------------

stringArray         :: String -> Array Int Char
stringArray string  = listArray (0,length string - 1) string

-- (!!!) is a variant of (!), which prints out the problem in case of
-- an index out of bounds.
(!!!)   :: Array Int a -> Int -> a
a!!! n  =  if n >= fst (bounds a) && n <= snd (bounds a) 
           then a!n 
           else error (show (snd (bounds a)) ++ " " ++ show n)