module Data.Algorithms.Palindromes.Palindromes
(palindrome
,palindromesAroundCentres
,dnaLengthGappedApproximatePalindromeAround
) where
import Data.List (maximumBy,intercalate)
import qualified Data.ByteString as B
import Data.Algorithms.Palindromes.PalindromesUtils
(showPalindrome
,showPalindromeDNA
,showTextPalindrome
,myToLower
,myIsLetterW
,listArrayl0
,appendseq
,Flag(..)
,(=:=)
,surroundedByPunctuation
)
import qualified Data.Sequence as S
import Data.Word (Word8)
import Data.Array(Array,(!))
palindrome :: Maybe Flag -> Maybe Flag -> Maybe Flag -> Maybe Flag -> Maybe Flag -> Maybe Flag -> B.ByteString -> String
palindrome palindromeVariant outputFormat algorithmComplexity lengthModifier gap nrOfErrors input =
let predicate = case lengthModifier of
Just (LengthAtLeast m) -> (m<=)
Just (LengthAtMost m) -> (<=m)
Just (LengthExact m) -> \l -> m<=l && (odd l == odd m)
Just (LengthBetween m n) -> \pl -> pl >= m && pl <= n
_ -> const True
post = case lengthModifier of
Just (LengthExact m) -> \_ -> m
_ -> id
textinput = B.map myToLower (B.filter myIsLetterW input)
positionTextInput = listArrayl0 (B.findIndices myIsLetterW input)
input' = case palindromeVariant of
Just Text -> textinput
Just Word -> textinput
_ -> input
show' = case palindromeVariant of
Just Text -> showTextPalindrome input positionTextInput
Just Word -> showTextPalindrome input positionTextInput
Just DNA -> showPalindromeDNA input
_ -> showPalindrome input
outputf = case outputFormat of
Just LengthLongest -> show . maximum . map post . filter predicate
Just Maximal -> intercalate "\n" . map show' . map (\(l,r) -> (post l,r)) . filter (predicate . fst) . flip zip [0..]
Just LengthMaximal -> show . map post . filter predicate
_ -> show' . maximumBy (\(l,_) (l',_) -> compare l l') . map (\(l,r) -> (post l,r)) . filter (predicate . fst) . flip zip [0..]
in outputf $ palindromesAroundCentres palindromeVariant algorithmComplexity gap nrOfErrors input input' positionTextInput
palindromesAroundCentres :: Maybe Flag -> Maybe Flag -> Maybe Flag -> Maybe Flag -> B.ByteString -> B.ByteString -> Array Int Int -> [Int]
palindromesAroundCentres palindromeVariant algorithmComplexity gap nrOfErrors input input' positionTextInput =
case (algorithmComplexity,gap,nrOfErrors) of
(Just Linear ,Nothing,Nothing) -> case palindromeVariant of
Just DNA -> reverse $ appendseq $ extendPalindromeS 2 0 input' [] S.empty 0 0
Just Word -> reverse $ map (head . snd) $ extendTailWord input input' positionTextInput [] 0 (0,[0])
_ -> reverse $ appendseq $ extendPalindromeS 1 1 input' [] S.empty 0 0
(Just Linear ,_ ,_ ) -> error "palindromesAroundCentres: cannot calculate approximate or gapped palindromes using the linear-time algorithm"
(Just Quadratic,g ,k ) -> let g' = case g of
Just (Gap g'') -> g''
_ -> 0
k' = case k of
Just (NrOfErrors k'') -> k''
_ -> 0
in gappedApproximatePalindromesAroundCentres palindromeVariant input g' k'
(_ ,_ ,_ ) -> error "palindromesAroundCentres: case not defined"
extendPalindromeS :: Int -> Int -> B.ByteString -> [Int] -> S.Seq Int -> Int -> Int -> ([Int],S.Seq Int)
extendPalindromeS centerfactor tailfactor input =
let ePS maximalPalindromesPre maximalPalindromesIn rightmost currentPalindrome
| rightmost > lastPos
= finalPalindromesS centerfactor currentPalindrome maximalPalindromesPre (currentPalindrome S.<| maximalPalindromesIn) maximalPalindromesIn
| rightmostcurrentPalindrome == first ||
not (B.index input rightmost == B.index input (rightmostcurrentPalindrome1))
= mCS rightmost maximalPalindromesPre (currentPalindrome S.<| maximalPalindromesIn) maximalPalindromesIn currentPalindrome
| otherwise
= let (left,rest) = splitAt 2 maximalPalindromesPre
in ePS rest (foldr (flip (S.|>)) maximalPalindromesIn left) (rightmost+1) (currentPalindrome+2)
where first = 0
lastPos = B.length input 1
mCS rightmost maximalPalindromesPre maximalPalindromesIn maximalPalindromesIn' nrOfCenters
| nrOfCenters == 0
= ePS maximalPalindromesPre maximalPalindromesIn (rightmost+1) tailfactor
| nrOfCenterscenterfactor == S.index maximalPalindromesIn' 0
= ePS maximalPalindromesPre maximalPalindromesIn rightmost (nrOfCenterscenterfactor)
| otherwise
= case S.viewl maximalPalindromesIn' of
headq S.:< tailq -> mCS rightmost maximalPalindromesPre (min headq (nrOfCenterscenterfactor) S.<| maximalPalindromesIn) tailq (nrOfCenterscenterfactor)
S.EmptyL -> error "extendPalindromeS: empty sequence"
in ePS
finalPalindromesS :: Int -> Int -> [Int] -> S.Seq Int -> S.Seq Int -> ([Int],S.Seq Int)
finalPalindromesS centerfactor nrOfCenters maximalPalindromesPre maximalPalindromesIn maximalPalindromesIn'
| nrOfCenters == 0
= (maximalPalindromesPre,maximalPalindromesIn)
| nrOfCenters > 0
= case S.viewl maximalPalindromesIn' of
headq S.:< tailq -> finalPalindromesS centerfactor (nrOfCenterscenterfactor) maximalPalindromesPre (min headq (nrOfCenterscenterfactor) S.<| maximalPalindromesIn) tailq
S.EmptyL -> error "finalPalindromesS: empty sequence"
| otherwise
= error "finalPalindromesS: input < 0"
gappedApproximatePalindromesAroundCentres :: Maybe Flag -> B.ByteString -> Int -> Int -> [Int]
gappedApproximatePalindromesAroundCentres palindromeVariant input g k =
case palindromeVariant of
Just DNA -> map (lengthGappedApproximatePalindromeAround (=:=) 1 input g k) (if even g then [0 .. B.length input] else [0 .. B.length input1])
_ -> map (lengthGappedApproximatePalindromeAround (==) 2 input g k) [0 .. 2*B.length input]
lengthGappedApproximatePalindromeAround :: (Word8 -> Word8 -> Bool) -> Int -> B.ByteString -> Int -> Int -> Int -> Int
lengthGappedApproximatePalindromeAround (===) centerfactor input g k center =
let halfg = div g 2
c = div center centerfactor
lengthInput = B.length input
halfg' | c < halfg = c
| c + halfg > lengthInput = lengthInputc
| otherwise = halfg
left = c1halfg'
right = if even g then c+halfg' else c+1+halfg'
in lengthApproximatePalindrome (===) input k left right
lengthApproximatePalindrome :: (Word8 -> Word8 -> Bool) -> B.ByteString -> Int -> Int -> Int -> Int
lengthApproximatePalindrome (===) input k start end
| start < 0 || end > lastPos = endstart1
| B.index input start === B.index input end = lengthApproximatePalindrome (===) input k (start1) (end+1)
| k > 0 = lengthApproximatePalindrome (===) input (k1) (start1) (end+1)
| otherwise = endstart1
where lastPos = B.length input 1
dnaLengthGappedApproximatePalindromeAround :: Maybe Flag -> Maybe Flag -> Int -> B.ByteString -> String
dnaLengthGappedApproximatePalindromeAround (Just (Gap gap)) (Just (NrOfErrors k)) center input = show $ lengthGappedApproximatePalindromeAround (=:=) 1 input gap k center
dnaLengthGappedApproximatePalindromeAround _ _ center input = show $ lengthGappedApproximatePalindromeAround (=:=) 1 input 0 0 center
extendTailWord :: B.ByteString -> B.ByteString -> Array Int Int -> [(Int,[Int])] -> Int -> (Int,[Int]) -> [(Int,[Int])]
extendTailWord input textInput positionTextInput centres n current@(currentTail,currentTailWords)
| n > alast =
finalWordCentres input textInput positionTextInput (current:centres) currentTail centres (1+length centres)
| ncurrentTail == afirst =
extendWordCentres input textInput positionTextInput (current:centres) n centres currentTail
| B.index textInput n == B.index textInput (ncurrentTail1) =
if surroundedByPunctuation (positionTextInput!(ncurrentTail1)) (positionTextInput!n) input
then extendTailWord input textInput positionTextInput centres (n+1) (currentTail+2,currentTail+2:currentTailWords)
else extendTailWord input textInput positionTextInput centres (n+1) (currentTail+2,currentTailWords)
| otherwise =
extendWordCentres input textInput positionTextInput (current:centres) n centres currentTail
where (afirst,alast) = (0,B.length textInput 1)
extendWordCentres :: B.ByteString -> B.ByteString -> Array Int Int -> [(Int,[Int])] -> Int -> [(Int,[Int])] -> Int -> [(Int,[Int])]
extendWordCentres input textInput positionTextInput centres n tcentres centreDistance
| centreDistance == 0 =
if surroundedByPunctuation (positionTextInput!n) (positionTextInput!n) input
then extendTailWord input textInput positionTextInput centres (n+1) (1,[1,0])
else extendTailWord input textInput positionTextInput centres (n+1) (1,[0])
| centreDistance1 == fst (head tcentres) =
let (currentTail,oldWord:oldWords) = head tcentres
in if surroundedByPunctuation (positionTextInput!(ncurrentTail)) (positionTextInput!(n1)) input
then if oldWord == currentTail
then extendTailWord input textInput positionTextInput centres n (head tcentres)
else extendTailWord input textInput positionTextInput centres n (currentTail,currentTail:oldWord:oldWords)
else if oldWord == currentTail && oldWord > 0
then extendTailWord input textInput positionTextInput centres n (currentTail, tail (snd (head tcentres)))
else extendTailWord input textInput positionTextInput centres n (head tcentres)
| otherwise =
let newTail = min (fst (head tcentres)) (centreDistance1)
oldWord = head (snd (head tcentres))
newWords | oldWord < newTail
= if surroundedByPunctuation (positionTextInput!(nnewTail+1)) (positionTextInput!n) input
then newTail:snd (head tcentres)
else snd (head tcentres)
| null (tail (snd (head tcentres)))
= snd (head tcentres)
| otherwise
= tail (snd (head tcentres))
in extendWordCentres input textInput positionTextInput ((newTail,newWords):centres) n (tail tcentres) (centreDistance1)
finalWordCentres :: B.ByteString -> B.ByteString -> Array Int Int -> [(Int,[Int])] -> Int -> [(Int,[Int])] -> Int -> [(Int,[Int])]
finalWordCentres input textInput positionTextInput centres n tcentres mirrorPoint
| n == 0 = centres
| n > 0 = let tlast = B.length textInput 1
(oldTail,oldWord:oldWords) = head tcentres
newTail = min oldTail (n1)
newWord = min oldWord (n1)
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 | surroundedByPunctuation (positionTextInput!tailFirstMirror) (positionTextInput!tailLastMirror) input
= if newWord == newTail
then newTail:oldWords
else newTail:oldWord:oldWords
| surroundedByPunctuation (positionTextInput!wordFirstMirror) (positionTextInput!wordLastMirror) input ||
null oldWords = newWord:oldWords
| otherwise = oldWords
in finalWordCentres input textInput positionTextInput ((newTail,newWords):centres) (n1) (tail tcentres) (mirrorPoint+1)
| otherwise = error "finalWordCentres: input < 0"