content: import           Control.Monad (guard)
  import           Data.List     (intersect, unfoldr, delete, nub, group, sort)
  import           Text.Printf   (printf)
  
  type Fraction = (Int, Int)
  type Reduction = (Fraction, Fraction, Int)
  
  validIntegers :: [Int] -> [Int]
  validIntegers xs = [x | x <- xs, not $ hasZeros x, hasUniqueDigits x]
    where
      hasZeros = elem 0 . digits 10
      hasUniqueDigits n = length ds == length ul
        where
          ds = digits 10 n
          ul = nub ds
  
  possibleFractions :: [Int] -> [Fraction]
  possibleFractions = (\ys -> [(n,d) | n <- ys, d <- ys, n < d, gcd n d /= 1]) . validIntegers
  
  digits :: Integral a => a -> a -> [a]
  digits b = unfoldr (\n -> guard (n /= 0) >> pure (n `mod` b, n `div` b))
  
  digitsToIntegral :: Integral a => [a] -> a
  digitsToIntegral = sum . zipWith (*) (iterate (*10) 1)
  
  findReductions :: Fraction -> [Reduction]
  findReductions z@(n1, d1) = [ (z, (n2, d2), x)
                                | x <- digits 10 n1 `intersect` digits 10 d1,
                                  let n2 = dropDigit x n1
                                      d2 = dropDigit x d1
                                      decimalWithDrop = realToFrac n2 / realToFrac d2,
                                  decimalWithDrop == decimal ]
     where dropDigit d = digitsToIntegral . delete d . digits 10
           decimal = realToFrac n1 / realToFrac d1
  
  findGroupReductions :: [Int] -> [Reduction]
  findGroupReductions = (findReductions =<<) . possibleFractions
  
  showReduction :: Reduction -> IO ()
  showReduction ((n1,d1),(n2,d2),d) = printf "%d/%d = %d/%d by dropping %d\n" n1 d1 n2 d2 d
  
  showCount :: [Reduction] -> Int -> IO ()
  showCount xs n = do
    printf "There are %d %d-digit fractions of which:\n" (length xs) n
    mapM_ (uncurry (printf "%5d have %d's omitted\n")) (countReductions xs) >> printf "\n"
    where
      countReductions = fmap ((,) . length <*> head) . group . sort . fmap (\(_, _, x) -> x)
  
  main :: IO ()
  main = do
    mapM_ (\g -> mapM_ showReduction (take 12 g) >> printf "\n") groups
    mapM_ (uncurry showCount) $ zip groups [2..]
    where
      groups = [ findGroupReductions [10^1..99],   findGroupReductions [10^2..999]
               , findGroupReductions [10^3..9999], findGroupReductions [10^4..99999] ]
  