palindromes-0.4: src/Data/Algorithms/Palindromes/PalindromesUtils.hs
-----------------------------------------------------------------------------
--
-- Module : Data.Algorithms.Palindromes.PalindromesUtils
-- Copyright : (c) 2007 - 2013 Johan Jeuring
-- License : BSD3
--
-- Maintainer : johan@jeuring.net
-- Stability : experimental
-- Portability : portable
--
-----------------------------------------------------------------------------
module Data.Algorithms.Palindromes.PalindromesUtils
(Flag(..)
,negateDNA
,showPalindromeDNA
,(=:=)
,showPalindrome
,showTextPalindrome
,myIsLetterC
,myIsLetterW
,myToLower
,surroundedByPunctuation
,appendseq
,listArrayl0
) where
import Data.Word (Word8)
import Data.Char (toLower,toUpper,isPunctuation,isSpace,isControl)
import Data.Array (Array,bounds,listArray,(!))
import qualified Data.ByteString as B
import Data.ByteString.Internal (w2c,c2w)
import qualified Data.Sequence as S
-----------------------------------------------------------------------------
-- Flags a user can specify
-----------------------------------------------------------------------------
data Flag = -- Palindromic variants (choose 1 out of 6; mutually exclusive):
Help
| Plain
| Text
| Word
| DNA
| Extend Int
-- Algorithm complexity (choose 1 out of 2; mutually exclusive):
| Linear
| Quadratic
-- Output format (choose 1 out of 4; mutually exclusive):
| Longest
| LengthLongest
| Maximal
| LengthMaximal
-- Modifiers (choose 0 to 5; where the length restrictions need to fit together)
| Gap Int
| NrOfErrors Int
| LengthAtLeast Int
| LengthAtMost Int
| LengthExact Int
| LengthBetween Int Int -- input via AtLeast and AtMost. Adapt?
-- Input format
| StandardInput
-----------------------------------------------------------------------------
-- Equality on DNA
-----------------------------------------------------------------------------
negateDNA :: Char -> Char
negateDNA 'A' = 'T'
negateDNA 'T' = 'A'
negateDNA 'C' = 'G'
negateDNA 'G' = 'C'
negateDNA _ = error "negateDNA: not a DNA character"
(=:=) :: Word8 -> Word8 -> Bool
l =:= r = let cl = toUpper (w2c l)
cr = toUpper (w2c r)
in if cl `elem` "ATCG" && cr `elem` "ATCG"
then cl == negateDNA cr
else False
-----------------------------------------------------------------------------
-- Showing DNA palindromes
-----------------------------------------------------------------------------
showPalindromeDNA :: B.ByteString -> (Int,Int) -> String
showPalindromeDNA input (len,pos) =
let startpos = pos - len `div` 2
in (show startpos ++)
. (" to " ++)
. (show (startpos+len) ++)
. ("\t" ++)
. (show (B.take len $ B.drop startpos input) ++)
. ("\t" ++)
$ show len
-----------------------------------------------------------------------------
-- Showing palindromes and other text related functionality
-----------------------------------------------------------------------------
showPalindrome :: B.ByteString -> (Int,Int) -> String
showPalindrome input (len,pos) =
let startpos = pos `div` 2 - len `div` 2
in show $ B.take len $ B.drop startpos input
showTextPalindrome :: B.ByteString -> Array Int Int -> (Int,Int) -> String
showTextPalindrome input positionTextInput (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
(pfirst,plast) = bounds positionTextInput
(ifirst,ilast) = (0,1 + B.length input)
in if endpos < startpos
then []
else let start = if startpos > pfirst
then (positionTextInput!(startpos-1))+1
else ifirst
end = if endpos < plast
then (positionTextInput!(endpos+1))-1
else ilast
in show (B.take (end-start+1) (B.drop start input))
{- Using this code instead of the last else above shows text palindromes without
all punctuation around it. Right now this punctuation is shown.
else let start = positionArray!!!startpos
end = positionArray!!!endpos
-}
-- For palindromes in strings, punctuation, spacing, and control characters
-- are often ignored
myIsLetterW :: Word8 -> Bool
myIsLetterW c' = not (isPunctuation c)
&& not (isControl c)
&& not (isSpace c)
where c = w2c c'
myIsLetterC :: Char -> Bool
myIsLetterC c = not (isPunctuation c)
&& not (isControl c)
&& not (isSpace c)
myToLower :: Word8 -> Word8
myToLower = c2w . toLower . w2c
surroundedByPunctuation :: Int -> Int -> B.ByteString -> Bool
surroundedByPunctuation begin end input
| begin > afirst && end < alast = not (myIsLetterW (B.index input (begin-1))) && not (myIsLetterW (B.index input (end+1)))
| begin <= afirst && end < alast = not (myIsLetterW (B.index input (end+1)))
| begin <= afirst && end >= alast = True
| begin > afirst && end >= alast = not (myIsLetterW (B.index input (begin-1)))
| otherwise = error "surroundedByPunctuation"
where (afirst,alast) = (0,B.length input - 1)
-----------------------------------------------------------------------------
-- Seq utils
-----------------------------------------------------------------------------
appendseq :: ([a],S.Seq a) -> [a]
appendseq (list,s) = tolist s ++ list
tolist :: S.Seq a -> [a]
tolist s = case S.viewl s of
S.EmptyL -> []
a S.:< r -> a:tolist r
-----------------------------------------------------------------------------
-- Array utils
-----------------------------------------------------------------------------
listArrayl0 :: [a] -> Array Int a
listArrayl0 string = listArray (0,length string - 1) string