StringCollapse.hs

{-# LANGUAGE TupleSections #-}
module Main where
-- see https://plus.google.com/u/0/105746006385940131491/posts/9Uev6KVRUgK for
-- context

-- what we essentially have is a non-associative operation (represented by
-- concatenation):
--
--    ab = ba = c
--    bc = cb = a
--    ac = ca = b
--
-- Non-associative since:
--
--    aa == a(bc) /= (ab)c == cc
--
-- The question boils down to what's the minimum length value we can generate
-- for some parenthesization of the input.
--
-- We know that any minimum length value must be a homogenous string,
-- so any parenthesization that doesn't produce a homogenous string
-- we can disregard

import Control.Monad (forM_)
import Data.Map (assocs, insertWith, empty)
import Data.Vector (fromList, (!))
import Data.List (minimumBy)
import Data.Function (on)

-- a region (c, n) is a homogeneous substring of n c characters
type Region = (Char, Int)

-- this is our basic operation 
(#) :: Region -> Region -> Maybe Region
-- if we can reduce two singleton regions into another, do so
('a', 1) # ('b', 1)      = Just ('c', 1)
('b', 1) # ('a', 1)      = Just ('c', 1)
('b', 1) # ('c', 1)      = Just ('a', 1)
('c', 1) # ('b', 1)      = Just ('a', 1)
('c', 1) # ('a', 1)      = Just ('b', 1)
('a', 1) # ('c', 1)      = Just ('b', 1)
-- if we can concat two regions of the same character, do so
(x, n) # (y, m) | x == y = Just (x, n + m)
-- otherwise, we can't produce a homogenous region
_        # _             = Nothing

-- transform the given list of pairs, combining values
-- for each key so the result only has one key per value
combineBy :: Ord a => (b -> b -> b) -> [(a,b)] -> [(a,b)]
combineBy f = assocs . foldr (uncurry $ insertWith f) empty

-- find all the reductions to a homogeneous region
reductions :: String -> [Region]
reductions "" = []
reductions s = lookup 0 n
  where n = length s
        lookup i m = cache ! i ! (m - 1)
        -- break the string up into a vector of singleton regions
        v = fromList $ map (,1) s
        -- for each span of regions, cache the reductions
        cache = fromList [ fromList [ calc i m | m <- [1 .. n-i] ] | i <- [0 .. n-1] ]
        -- for a given span of regions, find the smallest reductions
        calc i 1 = [ v!i ] -- singleton
        calc i m = combineBy min $ do
          -- for each split of the span into two halves
          k <- [1 .. m-1]
          -- for each combination of reductions
          -- of the two halves
          x <- lookup i k
          y <- lookup (i+k) (m-k)
          -- see if the result can be combined into
          -- a homogenous region
          maybe [] return (x#y)

-- just the smallest reduction
reduce :: String -> Maybe Region
reduce "" = Nothing
reduce s = Just . minimumBy (compare `on` snd) . reductions $ s

main :: IO ()
main = do
  forM_ ["", "aab", "bbcccccc", "cab", "bcab", "ccaca", "abcc", "aabcbccbaacaccabcbcab"] $ \s -> do
    putStrLn $ s ++ ": " ++ show (reduce s)