string puzzle solution

strpuzzle.hs

module Main where
import Data.List
import Data.List.Split

-- performs the transformation of adjacent strings                                
tr :: String -> String
tr s = case s of
  "ab" -> "c"
  "ba" -> "c"
  "ac" -> "b"
  "ca" -> "b"
  "bc" -> "a"
  "cb" -> "a"
  -- any string that is a single letter or a pair of the same, return it back     
  _ -> s

-- performs the transformation over a list of string lists                        
tr_all :: [[String]] -> [[String]]
tr_all (x:xs) = map tr x : tr_all xs
tr_all [] = []

-- best illustrated with examples:                                                
-- "abcbac" -> [["a","bc","ba","c"],["ab","c","ba","c"],["ab","cb","ac"]]         
-- "ababb"  -> [["a","ba","bb"],["ab","a","bb"],["ab","ab","b"]]                  
-- basically create the pairwise matching permutations in a string                
byTwos :: String -> [[String]]
byTwos s = nub $ map (bt s) [0..(length s)-1]
           where
             bt :: String -> Int -> [String]
             bt s i = let a = take (2*i) s
                          b = drop (2*i) $ take ((2*i)+1) s
                          c = drop ((2*i)+1) s in
                      case length c of
                        -- prevent case of last two elements being single chars   
                        1 -> splitEvery 2 a ++ splitEvery 2 (b++c)
                        _ -> splitEvery 2 a ++ splitEvery 2 b ++ splitEvery 2 c

-- determine the minimum count as described by the problem                        
puzzleCount s = case length $ nub s of
  -- "ccccc" implies a nub'd string with length 1, it cannot be reduced           
  1 -> length s
  -- find the minimum count for the different transformed permutations            
  _ -> minimum $ g s
    where
      g s = let
        -- the list of pairwise permutations                                      
        byTwosList = byTwos s
        -- doing the char transformations on them                                 
        trList     = tr_all byTwosList
        -- if one of the byTwos permutations was something like                   
        -- ["aa","b"]                                                             
        -- that will not be changed by tr. so we might as well                    
        -- just get its count, in this case 3. get all such counts                
        ucount     = unchangedCount byTwosList trList
        -- remove these unchanged permutations from working set                   
        cList      = changedList byTwosList trList
        -- for tr'd permutations we want to explore, collapse them                
        -- into strings again. for example                                        
        -- ["ba","a"] ->tr_all-> ["c","a"] ->to-String-> "ca"                     
        trStr      = map concat cList in
        (map puzzleCount trStr) ++ ucount
          where
                 unchangedCount :: [[String]] -> [[String]] -> [Int]
                 unchangedCount (x:xs) (y:ys) = case (x == y) of
                   True  -> (length $ concat x) : unchangedCount xs ys
                   False -> unchangedCount xs ys
                 unchangedCount _ _ = []
                 changedList :: [[String]] -> [[String]] -> [[String]]
                 changedList (x:xs) (y:ys) = case (x == y) of
                   True  -> changedList xs ys
                   False -> y : changedList xs ys
                 changedList _ _ = []

main :: IO ()
main = do
  print $ puzzleCount "aab"
  print $ puzzleCount "bbcccccc"
  print $ puzzleCount "cab"
  print $ puzzleCount "bcab"
  print $ puzzleCount "aabcbccbaacaccabcbcab"
  print $ puzzleCount "ccaca"
  return ()