

 This page uses content from Wikipedia. The original article was at Burrows–Wheeler_transform. The list of authors can be seen in the page history. As with Rosetta Code, the text of Wikipedia is available under the GNU FDL. (See links for details on variance)



The Burrows–Wheeler transform (BWT, also called block-sorting compression) rearranges a character string into runs of similar characters.

This is useful for compression, since it tends to be easy to compress a string that has runs of repeated characters by techniques such as move-to-front transform and run-length encoding.

More importantly, the transformation is reversible, without needing to store any additional data.

The BWT is thus a "free" method of improving the efficiency of text compression algorithms, costing only some extra computation.



Source: Burrows–Wheeler transform

-- A straightforward, inefficient implementation of the Burrows–Wheeler
-- transform, based on the description in the Wikipedia article.
--
-- Special characters are *not* used to indicate the start or end of sequences,
-- so all strings can be represented.
 
import Data.List ((!!), find, sort, tails, transpose)
import Data.Maybe (fromJust)
import Text.Printf (printf)
 
newtype BWT a = BWT [Val a]
 
bwt :: Ord a => [a] -> BWT a
bwt xs = let n  = length xs + 2
             ys = transpose $ sort $ take n $ tails $ cycle $ pos xs
         in BWT $ ys !! (n-1)
 
invBwt :: Ord a => BWT a -> [a]
invBwt (BWT xs) = let ys = iterate step (map (const []) xs) !! length xs
                  in unpos $ fromJust $ find ((== Post) . last) ys
  where step = sort . zipWith (:) xs
 
 
data Val a = In a | Pre | Post deriving (Eq, Ord)
 
pos :: [a] -> [Val a]
pos xs = Pre : map In xs ++ [Post]
 
unpos :: [Val a] -> [a]
unpos xs = [x | In x <- xs]
 
 
main :: IO ()
main = mapM_ testBWT [ "", "a", "BANANA", "dogwood",
                       "TO BE OR NOT TO BE OR WANT TO BE OR NOT?",
                       "SIX.MIXED.PIXIES.SIFT.SIXTY.PIXIE.DUST.BOXES" ]
 
testBWT :: String -> IO ()
testBWT xs = let fwd = bwt xs
                 inv = invBwt fwd
             in printf "%s\n\t%s\n\t%s\n" xs (pretty fwd) inv
  where pretty (BWT ps) = map prettyVal ps
        prettyVal (In c) = c
        prettyVal Pre    = '^'
        prettyVal Post   = '|'