hpaste

{- fizzbuzz 'solutions' by Chris Kuklewicz, a la
http://weblog.raganwald.com/2007/01/dont-overthink-fizzbuzz.html
http://www.dougalstanton.net/blog/index.php/2008/02/26/my-shame-is-complete

The usual BSD 3 clause license.
-}

import Data.Array
import Data.List
import Data.Monoid
import Data.Maybe

import Control.Monad.Fix
import Control.Monad
import Control.Monad.Cont
import Data.IORef

-- main1's fizzbuzz is written in very imperative style, using the
-- "ContT IO" transformed monad to get callCC
main1 :: IO ()
main1 = fizzbuzz 1 100

-- marks where we can jump backward to.
makeLabel :: (MonadCont m) => m (m a)
makeLabel = callCC (\k -> return (fix k))

-- unused, but is a variant which also updates an 't' parameter
makeLabelArg :: (MonadCont m) => t -> m (t -> m b, t)
makeLabelArg a = callCC (\k -> return (fix (curry k),a))

fizzbuzz a b = flip runContT return $ callCC $ \exit -> let break = exit () in do
  v <- io (newIORef a)
  continue <- makeLabel
  x <- io (readIORef v)
  when (x > b) (break)
  io (writeIORef v (x+1))
  when (x `mod` 15 == 0) $ io (putStrLn "FizzBuzz") >> continue
  when (x `mod` 3 == 0) $ io (putStrLn "Fizz") >> continue
  when (x `mod` 5 == 0) $ io (putStrLn "Buzz") >> continue
  io (print x)
  continue
 where io = liftIO -- sugar

-- main2 and main3 use a reified description of the replacement
-- strings, the "Msg", to combine the Fizz and Buzz.  This is used in
-- main2 with a cyclic list to efficienty iterate over the range.  In
-- main3 this is put into an array for efficient random access.
main2 :: IO ()
main2 = putStr . unlines $ fizzbuzzFromTo 1 100

main3 :: IO ()
main3 = putStr . unlines $ map fizzbuzzAt [1..100]

data Msg a = Msg { msgPeriod :: Int   -- period
                 , msgs :: [Maybe a]  -- 0 based list of length msgPeriod
                 } deriving Show

-- Our smart constructor, replacte multiples of 'i' by 's'
msg i s | i < 1 = error "Need Postive cycle length"
        | otherwise = Msg i (Just s : replicate (pred i) Nothing)

-- Note that (mappend x mempty == x) and (mappend mempty x == x)
instance Monoid a => Monoid (Msg a) where
  mempty = Msg 1 [Nothing]
  mappend (Msg i xs) (Msg j ys) = let k = lcm i j
                                      f Nothing Nothing = Nothing
                                      f a b = Just $ (fromMaybe mempty a) `mappend` (fromMaybe mempty b)
                                      zs = take k $ zipWith f (cycle xs) (cycle ys)
                                  in Msg k zs
  mconcat [] = mempty
  mconcat [x] = x
  mconcat xs = let k = foldl' lcm 1 . map msgPeriod $ xs
                   f [] = Nothing
                   f ms = Just (mconcat ms)
                   zs = take k $ map (f . catMaybes) (transpose . map (cycle . msgs) $ xs)
               in Msg k zs

-- construct cylic list 'composed' of printing functions and apply to list.
-- Note that the 'composed' is contructed once and cached.
fizzbuzzFromTo :: Int -> Int -> [String]
fizzbuzzFromTo a b = zipWith ($) toApply [a..b]
  where toApply = drop (a `mod` k) composed
        (Msg k xs) = (msg 3 "Fizz") `mappend` (msg 5 "Buzz")
        composed :: [Int->String]
        composed = cycle $ map (maybe show const) xs

-- Note that the 'composed' array is contructed once and cached.
fizzbuzzAt :: Int -> String
fizzbuzzAt x = (composed ! mod x k) x
  where (Msg k xs) = (msg 3 "Fizz") `mappend` (msg 5 "Buzz")
        composed :: Array Int (Int->String)
        composed = listArray (0,pred k) . map (maybe show const) $ xs